ectrans-1.8.0/0000775000175000017500000000000015174632061013350 5ustar alastairalastairectrans-1.8.0/VERSION0000664000175000017500000000000615174631767014430 0ustar alastairalastair1.8.0 ectrans-1.8.0/tests/0000775000175000017500000000000015174631767014526 5ustar alastairalastairectrans-1.8.0/tests/compare_checksums.py0000775000175000017500000000540115174631767020576 0ustar alastairalastair#!/usr/bin/env python3 import sys import os import filecmp class colors: SUCCESS = '\033[94m' FAILURE = '\033[91m' ENDC = '\033[0m' def compare_checksums(folder_path, ntasks, nthreads): if not os.path.isdir(folder_path): print(f"Error: '{folder_path}' is not a valid directory.") return False print(f"Check files in folder {folder_path}:") success_count = 0 error_count = 0 total_count = 0 failed_list = [] for file_name in os.listdir(folder_path): if (".checksums" in file_name and "benchmark" in file_name and "mpi0_omp1" in file_name): file_path = os.path.join(folder_path, file_name) if os.path.isfile(file_path): print(f"{file_name}") found = False for mpi in ntasks: for omp in nthreads: other_file_name = file_name.replace("mpi0_omp1",f"mpi{mpi}_omp{omp}") if other_file_name == file_name: continue other_file_path = os.path.join(folder_path, other_file_name) if os.path.isfile(other_file_path): total_count = total_count + 1 found = True if (filecmp.cmp(file_path, other_file_path)): print(f" {other_file_name} ...{colors.SUCCESS}Passed{colors.ENDC}") success_count = success_count +1 else: print(f" {other_file_name} ...***{colors.FAILURE}Failed{colors.ENDC}") error_count = error_count + 1 failed_list.append(f"{file_path} {other_file_path}") if (not found): print(f" No comparison found") return False percentage = int(100*(success_count/total_count)) if (error_count> 0): print(f"{percentage}% comparison passed, {colors.FAILURE}{error_count} comparison failed out of {total_count}{colors.ENDC}") print("The following comparisons FAILED:") for failed in failed_list: print(f" {colors.FAILURE}{failed}{colors.ENDC}") else: print(f"{percentage}% checks passed") if (error_count > 0): return False return True if __name__ == "__main__": if len(sys.argv) != 4: print("Usage: python compare_checksums.py ") exit(1) else: folder = sys.argv[1] ntasks = sys.argv[2].split(",") nthreads = sys.argv[3].split(",") if compare_checksums(folder, ntasks, nthreads): exit(0) else: exit(1) ectrans-1.8.0/tests/test_install/0000775000175000017500000000000015174631767017233 5ustar alastairalastairectrans-1.8.0/tests/test_install/main.F900000664000175000017500000000137115174631767020441 0ustar alastairalastair! (C) Copyright 2020- ECMWF. ! ! 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. ! program main ! From library fiat use yomhook ! assert found use mpl_module ! assert found ! From library parkind_(dp|sp) use parkind1, only: JPRB ! assert found implicit none ! assert includes are found #include "setup_trans0.h" #include "trans_end.h" write(0,*) "JPRB =",JPRB ! depending on link with parkind_sp or parkind_dp this will print 4 or 8 end programectrans-1.8.0/tests/test_install/transi_sptogp.c0000664000175000017500000001037015174631767022274 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #include #include #include #include "ectrans/transi.h" #define TRANS_CHECK( CALL ) do {\ int errcode = CALL;\ if( errcode != TRANS_SUCCESS) {\ printf("ERROR: %s failed @%s:%d:\n%s\n",#CALL,__FILE__,__LINE__,trans_error_msg(errcode));\ abort();\ }\ } while(0) /*! @example transi_sptogp.c * * Transform spectral to gridpoint * * This is an example of how to setup and * transform global spectral data to * global gridpoint data */ // Following dummy functions are implementation details // that don't contribute to this example. They could be // replaced with grib_api functionality void read_grid( struct Trans_t* trans ); void read_rspecg( struct Trans_t* trans, double* rspecg[], int* nfrom[], int* nfld ); void write_rgpg( struct Trans_t* trans, double* rgpg[], int nfld ); int main ( int arc, char **argv ) { trans_use_mpi(0); int jfld; struct Trans_t trans; TRANS_CHECK(trans_new(&trans)); // Read resolution information read_grid(&trans); // Register resolution in trans library TRANS_CHECK( trans_setup(&trans) ); // Declare global spectral data int nfld; double* rspecg = NULL; int* nfrom = NULL; // Read global spectral data (could be from grib file) read_rspecg(&trans,&rspecg,&nfrom,&nfld); // Distribute data to all procs double* rspec = malloc( sizeof(double) * nfld *trans.nspec2 ); struct DistSpec_t distspec = new_distspec(&trans); distspec.nfrom = nfrom; distspec.rspecg = rspecg; distspec.rspec = rspec; distspec.nfld = nfld; TRANS_CHECK(trans_distspec(&distspec)); // Transform sp to gp fields double* rgp = malloc( sizeof(double) * nfld*trans.ngptot ); struct InvTrans_t invtrans = new_invtrans(&trans); invtrans.nscalar = nfld; invtrans.rspscalar = rspec; invtrans.rgp = rgp; TRANS_CHECK( trans_invtrans(&invtrans) ); // Gather all gridpoint fields double* rgpg = NULL; if( trans.myproc == 1 ) rgpg = malloc( sizeof(double) * nfld*trans.ngptotg ); int* nto = malloc( sizeof(int) * nfld ); for( jfld=0; jfldndgl=160; trans->nloen=malloc(sizeof(int)*trans->ndgl); for( i=0; indgl; i++) trans->nloen[i] = trans->ndgl*2; // Assume Linear Grid trans->nsmax=1279; //(2*trans->ndgl-1)/2; } void read_rspecg(struct Trans_t* trans, double* rspecg[], int* nfrom[], int* nfld ) { int i; int jfld; if( trans->myproc == 1 ) printf("read_rspecg ...\n"); *nfld = 2; if( trans->myproc == 1 ) { *rspecg = malloc( sizeof(double) * (*nfld)*trans->nspec2g ); for( i=0; inspec2g; ++i ) { (*rspecg)[i*(*nfld) + 0] = (i==0 ? 1. : 0.); // scalar field 1 (*rspecg)[i*(*nfld) + 1] = (i==0 ? 2. : 0.); // scalar field 2 } } *nfrom = malloc( sizeof(int) * (*nfld) ); for (jfld=0; jfld<(*nfld); ++jfld) (*nfrom)[jfld] = 1; if( trans->myproc == 1 ) printf("read_rspecg ... done\n"); } void write_rgpg(struct Trans_t* trans, double* rgpg[], int nfld ) { int jfld; if( trans->myproc == 1 ) printf("write_rgpg ...\n"); for( jfld=0; jfldmyproc == 1 ) printf("write_rgpg ... done\n"); } ectrans-1.8.0/tests/test_install/transi_gptosp.c0000664000175000017500000001253515174631767022301 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #include #include #include "ectrans/transi.h" #define TRANS_CHECK( CALL ) do {\ int errcode = CALL;\ if( errcode != TRANS_SUCCESS) {\ printf("ERROR: %s failed @%s:%d:\n%s\n",#CALL,__FILE__,__LINE__,trans_error_msg(errcode));\ abort();\ }\ } while(0) /*! @example transi_gptosp.c * * Transform gridpoint to spectral * * This is an example of how to setup and * transform global gridpoint data to * global spectral data */ // Following dummy functions are implementation details // that don't contribute to this example. They could be // replaced with grib_api functionality void read_grid( struct Trans_t* trans ); void read_rgpg( struct Trans_t* trans, double* rgpg[], int* nfrom[], int* nfld ); void write_rspecg( struct Trans_t* trans, double* rspecg[], int nfld ); int main ( int arc, char **argv ) { trans_use_mpi(0); int jfld; struct Trans_t trans; trans_new(&trans); // Read resolution information read_grid(&trans); // Register resolution in trans library trans_setup(&trans); // Declare global gridpoint data int nfld; double* rgpg = NULL; int* nfrom = NULL; // Read global gridpoint data (could be from grib file) read_rgpg(&trans,&rgpg,&nfrom,&nfld); // Distribute data to all procs double* rgp = malloc( sizeof(double) * nfld *trans.ngptot ); struct DistGrid_t distgrid = new_distgrid(&trans); distgrid.nfrom = nfrom; distgrid.rgpg = rgpg; distgrid.rgp = rgp; distgrid.nfld = nfld; trans_distgrid(&distgrid); // Transform gp to sp fields double* rspec = malloc( sizeof(double) * nfld*trans.nspec2 ); struct DirTrans_t dirtrans = new_dirtrans(&trans); dirtrans.nscalar = nfld; dirtrans.rgp = rgp; dirtrans.rspscalar = rspec; trans_dirtrans(&dirtrans); // Gather all spectral fields double* rspecg = NULL; if( trans.myproc == 1 ) rspecg = malloc( sizeof(double) * nfld*trans.nspec2g ); int* nto = malloc( sizeof(int) * nfld ); for( jfld=0; jfldndgl = sizeof(T159)/sizeof(int); trans->nloen = malloc( sizeof(T159) ); for( i = 0; indgl; i++) trans->nloen[i] = T159[i]; // Assume Linear Grid trans->nsmax=(2*trans->ndgl-1)/2; } void read_rgpg(struct Trans_t* trans, double* rgpg[], int* nfrom[], int* nfld ) { int i; int jfld; if( trans->myproc == 1 ) printf("read_rpgp ...\n"); *nfld = 2; if( trans->myproc == 1 ) { *rgpg = malloc( sizeof(double) * (*nfld)*trans->ngptotg ); for( i=0; ingptotg; ++i ) { (*rgpg)[0*trans->ngptotg + i] = 1.; // scalar field 1 (*rgpg)[1*trans->ngptotg + i] = 2.; // scalar field 2 } } *nfrom = malloc( sizeof(int) * (*nfld) ); for (jfld=0; jfld<(*nfld); ++jfld) (*nfrom)[jfld] = 1; if( trans->myproc == 1 ) printf("read_rpgp ... done\n"); } void write_rspecg(struct Trans_t* trans, double* rspecg[], int nfld ) { int i; if( trans->myproc == 1 ) printf("write_rspecg ...\n"); for( i=0; inspec2g; ++i ) { // output global fields rspecg[i][0:nfld-1] } if( trans->myproc == 1 ) printf("write_rspecg ... done\n"); } ectrans-1.8.0/tests/test_install/CMakeLists.txt0000664000175000017500000000240615174631767021775 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. cmake_minimum_required( VERSION 3.18 FATAL_ERROR ) project( ectrans_test_install VERSION 0.0.0 LANGUAGES Fortran ) set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) if( COMPONENTS ) find_package( ectrans REQUIRED COMPONENTS ${COMPONENTS} ) else() find_package( ectrans REQUIRED ) endif() if( TARGET trans_dp ) add_executable( main_dp main.F90 ) target_link_libraries( main_dp trans_dp ) endif() if( TARGET trans_sp ) add_executable( main_sp main.F90 ) target_link_libraries( main_sp trans_sp ) endif() if( TARGET transi_dp ) enable_language( C ) add_executable( transi_sptogp transi_sptogp.c ) target_link_libraries( transi_sptogp transi_dp ) add_executable( transi_gptosp transi_gptosp.c ) target_link_libraries( transi_gptosp transi_dp ) endif() ectrans-1.8.0/tests/test_ectrans4py/0000775000175000017500000000000015174631767017661 5ustar alastairalastairectrans-1.8.0/tests/test_ectrans4py/__init__.py0000664000175000017500000000000015174631767021760 0ustar alastairalastairectrans-1.8.0/tests/test_ectrans4py/test_ectrans4py.py0000664000175000017500000001277515174631767023402 0ustar alastairalastairfrom unittest import main, TestCase import numpy from . import data import ectrans4py import platform system = platform.system() if system == "Linux": ectrans4py.init_env(unlimited_stack=True) elif system == "Darwin": ectrans4py.init_env(unlimited_stack=False) else: raise NotImplementedError("ectrans4py does not support Windows") KNUMMAXRESOL = 10 EPSILON = 1e-10 class ArraysAlmostEqual(object): def assert_arrays_diff_under_epsilon(self, x, y): diff = x - y diffmax = abs(diff.max()) diffmin = abs(diff.min()) self.assertTrue(diffmax < EPSILON, "diffmax is {}".format(diffmax)) self.assertTrue(diffmin < EPSILON, "diffmin is {}".format(diffmin)) class TestLAM(TestCase, ArraysAlmostEqual): gpdims = {'X':54, 'Y':48, 'X_CIzone':43, 'Y_CIzone':37, 'X_resolution':1300.0, 'Y_resolution':1300.0} truncation = {'in_X':26, 'in_Y':23} spectral_data_sizes = (2592, 1968) spdata = data.antwrp1300['sp'] gpdata = data.antwrp1300['sp2gp'] def test_etrans_inq(self): spectral_data_sizes = ectrans4py.etrans_inq4py( self.gpdims['X'], self.gpdims['Y'], self.gpdims['X_CIzone'], self.gpdims['Y_CIzone'], self.truncation['in_X'], self.truncation['in_Y'], KNUMMAXRESOL, self.gpdims['X_resolution'], self.gpdims['Y_resolution']) self.assertEqual(spectral_data_sizes, self.spectral_data_sizes) def test_sp2gp(self): gpdata = ectrans4py.sp2gp_lam4py( self.gpdims['X'], self.gpdims['Y'], self.gpdims['X_CIzone'], self.gpdims['Y_CIzone'], self.truncation['in_X'], self.truncation['in_Y'], KNUMMAXRESOL, len(self.spdata.flatten()), False, # no derivatives False, # spectral_coeff_order != 'model', self.gpdims['X_resolution'], self.gpdims['Y_resolution'], self.spdata.flatten())[0] self.assert_arrays_diff_under_epsilon(gpdata, gpdata.flatten()) def test_gp2sp(self): spdata = ectrans4py.gp2sp_lam4py( self.spectral_data_sizes[1], self.gpdims['X'], self.gpdims['Y'], self.gpdims['X_CIzone'], self.gpdims['Y_CIzone'], self.truncation['in_X'], self.truncation['in_Y'], KNUMMAXRESOL, self.gpdims['X_resolution'], self.gpdims['Y_resolution'], False, # spectral_coeff_order != 'model', self.gpdata.flatten()) self.assert_arrays_diff_under_epsilon(spdata, spdata.flatten()) class TestGlobal(TestCase, ArraysAlmostEqual): gpdims = {'lat_number':150, 'lon_number_by_lat':data.lon_number_by_lat} truncation = {'max':148} spectral_data_sizes = ( 33052, 11175, data.zonal_wavenumbers) spdata = data.tl149_c24['sp'] gpdata_latlon = data.tl149_c24['sp2gp'] # Pack latlon gridded data to reduced grid gpdata = numpy.zeros((sum(gpdims['lon_number_by_lat']))) offset = 0 for i in range(gpdims['lat_number']): nlon = gpdims['lon_number_by_lat'][i] gpdata[offset:offset+nlon] = gpdata_latlon[i,:nlon] offset += nlon def test_get_legendre_assets(self): nspec = sum([self.truncation['max'] + 2 - im for im in range(self.truncation['max']+1)]) knmeng, weights, polys = ectrans4py.get_legendre_assets( self.gpdims['lat_number'], self.truncation['max'], len(self.gpdims['lon_number_by_lat']), nspec, self.gpdims['lon_number_by_lat'], KNUMMAXRESOL ) weights_sum = sum(weights) # The sum of the Gaussian weights should be equal to 1.0 self.assertTrue(abs(weights_sum - 1.0) < EPSILON, f"sum of weights is {weights_sum}") def test_trans_inq4py(self): spectral_data_sizes = ectrans4py.trans_inq4py( self.gpdims['lat_number'], self.truncation['max'], len(self.gpdims['lon_number_by_lat']), self.gpdims['lon_number_by_lat'], KNUMMAXRESOL) self.assertEqual(spectral_data_sizes[0:2], self.spectral_data_sizes[0:2]) # dimensions numpy.testing.assert_array_equal(spectral_data_sizes[2], self.spectral_data_sizes[2]) # zonal_wavenumbers def test_sp2gp(self): gpdata = ectrans4py.sp2gp_gauss4py( self.gpdims['lat_number'], self.truncation['max'], KNUMMAXRESOL, sum(self.gpdims['lon_number_by_lat']), len(self.gpdims['lon_number_by_lat']), self.gpdims['lon_number_by_lat'], len(self.spdata), False, # no derivatives False, # spectral_coeff_order != 'model', self.spdata)[0] self.assert_arrays_diff_under_epsilon(self.gpdata, gpdata) def test_gp2sp(self): spdata = ectrans4py.gp2sp_gauss4py( self.spectral_data_sizes[1] * 2, # *2 for complex coefficients self.gpdims['lat_number'], self.truncation['max'], KNUMMAXRESOL, len(self.gpdims['lon_number_by_lat']), self.gpdims['lon_number_by_lat'], len(self.gpdata), False, # spectral_coeff_order != 'model', self.gpdata) self.assert_arrays_diff_under_epsilon(self.spdata, spdata) ectrans-1.8.0/tests/test_ectrans4py/data/0000775000175000017500000000000015174631767020572 5ustar alastairalastairectrans-1.8.0/tests/test_ectrans4py/data/__init__.py0000664000175000017500000000107715174631767022710 0ustar alastairalastairimport numpy import os _here = os.path.abspath(os.path.dirname(__file__)) lon_number_by_lat = numpy.load(os.path.join(_here, 'lon_number_by_lat.npy')) zonal_wavenumbers = numpy.load(os.path.join(_here, 'zonal_wavenumbers.npy')) antwrp1300 = { 'sp' : numpy.load(os.path.join(_here, 'antwrp1300-s1t@sp.npy')), 'sp2gp' : numpy.load(os.path.join(_here, 'antwrp1300-s1t@sp2gp.npy')), } tl149_c24 = { 'sp' : numpy.load(os.path.join(_here, 'tl149-c24-s1t@sp.npy')), 'sp2gp' : numpy.load(os.path.join(_here, 'tl149-c24-s1t@sp2gp.npy')), } ectrans-1.8.0/tests/test_ectrans4py/data/tl149-c24-s1t@sp.npy0000664000175000017500000053536015174631767023751 0ustar alastairalastairNUMPYv{'descr': ' g!E?|hI:+߈l&6}1}in-N?HIGdXP?_JJߺg?HuWd?m"uԃ?ľ4K4|{HeĂ{?ܶ:Qn?f~`myvFq?0*z>ٔ?8㌊^ gY?Dϻx Eb^;eUNH?7cx>E ?D2lt?GK2#?D! QtϞ7Ha?+׬DITtD"2x?c{Tp?^|;AǾ`w]?jq=h[e_-:V?g,*5?G,s(v5ި[J:"]2Rc? E)mig?}垫HlW%0o?JK1uU$u? /q* Еq?ZFOY8i.RTf\?[T\2C;xkR?V7 c:2Af]?RCed?N9`wWJ?9 ^BF22-nF?$eT81hZ?t3EsLNV??Лc P-MiFA^hI?7yN mP?G dFQE$?tA?FrRAgUT?10QQbklG?Rglן{gB6@S?@gZ[?FR#W;,6K?&39@ҥxS?#mYiSZ?wS" D?3/N#'-۳Gm@!Bn.q? IǿQiA?@H񿞳ڿDB?(;=?fZZ?YR?xر?L?}*Ͽ2ZͿM?~v0|泿r*˿`h23+˫'ٻ?Ek?Fí\ƿ,T.?b=ܳ6ˡذlW214(pմk?d?Lsh;׏ZDb?w ;6?Ϗ0?m`?j62'ÿ}n1G?郎 +{?i:MU?H5u$8֚c+ݯ?=T2n'?,ƾ?E{J&? ռ?Dn~~+?%Ğ>?8p=+?O.?[}( ?u ?WJ L燿QaJX[?N?QVG@ '%AL?1K6@?]I?JF6`\?rM*m?6zͬt?M po\Z֐ b[&@?X˕s?^?7ǀ+?#u"y?t8c ٷa?A?.0=_P#TjZ?ĨH?k43\,R`s?5'?ܵي?0 [,?%ӊo?iR呿.ҪQ?1hg?ۥ Dpg3 ׇaRmI#Z?{q)Wό>U-? y%p?(TfpEem?~`Or 0K ~?:evQ,(]\VJ}v? Ԧ|CӺ???3k3^3Uc?U_R?w'fs4L0h$?W?Wދ^zxChfQ_2L\ޑ?g}sc?5ɌN}-02Ď?rC%Y?V}9;T?T.F,; y0pv?òraq?l?p?ƠӇ^̓]&DMX,rBʒ=)IdG=bFG?&f?$ܬ'*/[%eu#Qm uYO? ?(NSз |ZP?,@}"\ fR*?y$TV/o;G?c+ a?X(_1DeC.3j?ﵹj?Jhɕ?WaP kRb?dlP?@'cHB?9RTSs%=Yբ>O`?qa? :Qx^=~/rca⮃I?a?:lwFXQ;@V%J*?>F I?Z6q$SWHJ@pq@T?f*a1?QmKP @NVu2RA?ڂ;M?jikP>{r3 S%y;ce5%?(&L?ˮ'?dM-0Z,D?=? F*„24F3u#3½ +7֧[F?pN㻜#y) R_?#֫w?B!Jҡ섿+W?38xh?a[R/{s?TY*?έEWM#}#5|?W#bc#l?-WF?3Y*L߂q yg썁Vco5~di:~|z?۔Z|>!&7xJnp?"5L?&#{^JM\f?; ?HfsVwI'f1 /?4]<$[? [w\&sK+G c?ccfi?V=YaStF1>pY3w?䯢+MT!* VuУLLkAD\&ʐg8D=*c?.]8c33Qk}\8HN:Kg?~#jW?d-ds3?W?bfeb6?sϪ;r?]*SW>n-f%{EO?`lkd?!Caj?@O&?NWg/t]?odf?ߥ^{A ^U2ae"kG#i%X?y>+ͨGKys/9#3K B?;L@?_GKiA?4\s8A?OKiLw.<IxfS?ZJ+V?}|[LW?ZUkHqXDkK? < Y?E;Z/`'*?fG?ncoᡬMN:"?ت LN?9-kFj!?UD3?U:ނigD;?޴RAzSn, ?T ֣^?/+>0cC&WЙd?j<_7?<b 'ۻ>|SV\?bd?0C?HQEGщEq??NJ? 2?9Ng`= {?8O+'rH2rg?B=)?aâr|3R7?bν?@Ϻz -~(yi?Yj1j&0Tk$?pR$},߉(-qz?gjH?h)v&F]?>Lkwq?ok?ݕߩ?qZ?Z? !܉k23>?뗁z?tJ:1r^ʁ[?[i?^N#!H<· .΍9? $?2D60OIf0?1? }"IQ0rz?R`?N:d,:ynЌy?ori?wwstt?t[z?e nqH"$z?ƸE ^"!؆X2Ngfiz? l?x}d)lF:L߭?AgC:?&MZ?J(42?惠?%[&4?wtC&!T?v*4@''q*9;|f?(hf!Dv?,9͹n]PwV?>%L?QD+Q?_e^͗|W?Ԃh6E? qU?LfV-B?2|Rh6mC;?FSp?)k-b8Si@y~b?'51C?BO k8R?+f5$_?RqZa1^ZKr?dS?=Ynh^7P>5Jb?e7uI$?[~uU?P;(<[Z#?<"K?tB8Ptir%?Om0h? ,i5PU0sz(_?Bu?k>_N n{oZ?lHEb?ӆ2NyR>v\׽#%F?ZQ?W7ϲPm BR׎)?0]LL#aK3?2?K(y:93?[pIYB?WT+w=ϾF\?S<R>?~z`b< ?y fb?GZ2J[`C @?Y?.G_C2)Ig,?]片4?7V@?l_34NjQRi%"͒ X? e6E$? 6ѽ^h>m:h^?}A?=(`TC*09\?2ǿD?=VE_EZ1B? xtF?¨ +?>[F.AD@CB?Bm5N?WBlMNFmu> R"G?|8kI?rR1Q35V?el.U?<)X1\nU+N U?w2ɘR?l.JW.Kg?^@€:?@nC?c3p>XH)fQ;[95Vw=!U?D?#-Sj~cHL<*J?F?*8qϿ ?U41S{<$U7? -oݧĿ[?l\"ĿE`GȆƿF_`?;96Ɲҿ2ڿ}c?߲?z/ =$n.¿4%?oTK􋮿N>r? QXc,Ǻ?n ?ӉB]S?-h,B?>( 1C9"?r?fA}Ʈu?>L'?0.Jmwk$l?}8u?KF~,|媿tN#o?ER?&&3>d{?>+%1?hK?8(f|];?8Ϭ?gS ? .#Q~1f:9 T?H`Dt[&?g? ?DRx=9Z5p~|R3-R>vZ"ld"?a<?:c-1^vbG*Z?pAMh?j@` ŕDa S_?G]9.bd=xMx?m:Oʆ?:v1uȱS8?@e+x MJcCD?)ϭ "УF NPuqv?@ּ?ق.pi?[?=?p굄MyZ?KE?|qgb!S-a5AS?af%9y;V?ei?o[ʙB"qYr?z@J+5lIڋ?jR?Z,jF}7Mw?G;GAHS?W4i'k? ^z>8nj Dd6Ѝk?Zww?s>3tJ!/H?uZcU? V2?Ue͠?;l'p\eΣO@?˜Q1y?N엀<ك.@d4bG^v?7 v?Q{zyʞK ]{?ےg?ތp}?0\??"E?uS4l?"*HWyJ.ck Us?P|c?3Ic+PJKm%6z4@Liyu?V$Al{:mZhb?c 6S?Mݵ2q?݉Y[hOb?Es24m?ҹU3V?WrQqw]ynEhy?ee8Vv? D4x8H@ sJdWbs?e #s?:QWgsPl1r7T?Vc?H|{{E?z%ZJ6U6QY@݋b?ni`?dkG|֩P6̊ܥn?~<88ސoy&H4O?w_=^?ﺛbTl:?a(qj?'dc`Ģ vp?saMK?4|x5rGLV'w%q?Ew+^4\P?L?=VwW'ΑI?PsW?a+_FO L)YdY5?AS?0|??E#w@X?Tԕ iR?avX?,ZQgw]]?!(CU A+0KQ?@?k CcR) /?,|U?q~))cYYL> ?=?"8 \?Ŷ|OL\ZRUλ1Q?JW?^`DT/}O9V UT?x 6G?-JruK&C:?)a68 D&$?k"C?0?#p^AsΕ3>H{nC?D#:>?Z z/?gP#)˛2>e[R?ͅlSh[҂ Q k? hH?>VU(?,Sm3.9z7XE?@L?֤#aGdk"/R H( B?CܬR? r3]_Grlc hf6?_}E?y?Q>l=t Q?ٛBB?!|H)+kF.̔?_^Ġ?wmP?{6 ?s6ۿ F ?46ԠĿ8˄=?-xt?o$i*?QΝIa?qX9Isw%>db䯭? ጐ? s+*Ŕ?f?9zF3?KBw(-?q_B?\v?B}N̷`b?!eNu?BGA_WtC?534\?_x[|2NYB/ ?v)-C3 tNV?{/~a=0W-}~g\~~Ÿ, u? ZnwEc!ˇj}#t?y<c6%_R?b|ud?w{?P\xN0٤?5݇?L`{pp&7-i?Lq?{G oKT(?g`ʫm?dj1fyɹ0?Y3NI;Z_?yqpv0^(RPOLu?fuzt?ÌX rPKɅk[?1c?@ 0i?On+p%p*y?=7Xբ?uO;MAÊ\!ѕtz|F?'WUEi?pQ1gͫdd=^3q?,|X?%.i Q@Txjn?jLT?apScR'sP|? k(aw?*b傿To|nҤeCK-yG?D[֢vI?c&RR/2w5Z?_j5ȮO[qȣ>?V?F1O6<,QS%$5P?#Kw=? ӌJ o*9T'?^S6fel>?uS0??}Q<Bl(X? D?XiZ8.]9y~`rV}?Gz?홊E?; !j}TOW3/?EJhX?xBJڮ30OJ"YFR2?ƃQ?8#,BrW F?uL`XD?}u^*7t% Þx?~w?c{=":_?â?3~υx?f.Q.'?d2C ȸض[>kqE?MS?>CvE I]0RΐJ?\.?<?ޥkm*.lT?p#? وa^nmQB(Y?PgIRJZ3:q?0}A1?ɳ̌;$t\z1y?ۮs?n[|?!M{? Csu?)$ᎿpfT??$hn? ݞS Jp\RL?z?:ֲqY1}(㝭E?xp^cc=oTFU1?;?!Kf!s!5"?Ah)dkkj?Fz?J'\| Ǒ9h7ti?bNxiH?K ^3K??v4Q`mP?2>Q,:!k4I]'I'1?VkGZ?v cba7?bHf?цR1BY;f8KI?"b0d?1K4\m&g@?d7 JvP?T=2`הCi*(x5 zR?pB2~C?{YٺL)\^?HJ?.G{n] rgGƴ*$W?-7>? mHwת'#"@o ?)$]L:"?TC8S۾2(?/Tu=aT3( ?F% L?C?cSRV6Eh"uS?,M?I2PuFJXYcD?Z`?[$) bcZkY6+e1`?#BJ@?ƫ2TdD AE?:}Q? Ail? s?؅09?F9XLX,-?>\`M7J??^/|ZϺc YH٢?pZ?B.:@?Kة?s+1ӈ?3yJ? ͤ!zŲpgJʠ?M?O*D?_r e?6^+,??W _>㡲/*ܮ07(ڏ?tP\9qI?c݁? Ȅ?3Dc1FWNY??z}ꋸp> JJh#ɖ?B?[7SAg[-" Xb&a M?4GXǶY$欿)?H#k?wz5Iť"?ұP>?2uOe?0 hIVw1GUzlϵ |Ț?K9-Mx?x?093UCbqh?TwOYY|<ɘ?XTfxXA?s ?}_1LgT~Mv?Wc?"[ 8Z蘿6?8j ݑ?}F {U_Kz5$?\Y5<Ʉ?a)*v ̯?sX e m;ä8{?6c(kw?v}`\끿O>? tx?  t{[|?HG1?0_<j=ǟNMV>m?c?:/OU?ҦYNyODonc?J%#t?@;U SۍĀu/T*Es?꾱[?ZU\m`H?*fmU? Hirm#-?k"w?} J? Òl#x^O?;py?PÛ?iaP;qx (ż`q?~ ]r?S͞ mX 3o?^nsG~edd?вMa?&-d4?.1̯ d?}# b}l??Ƈ1K1c?#g#@"z^>?Qu S?OĆ RJt.)T2wE̯D?X>?Q?,JACuRR|J?!\QL?TF+LR@#LD?c1V$ҖiE}@?앀]B?~9|,KҼBH?bdG?}Dz0v ZHF7 A? jF?P>CSU? <)Yx]d`Ƅ> : R]?լ6?ztsgV'ѓKHqB E?KR?zfV3?ALW,[dR5Bƿ#D}t?i,е%XU?"ō?HS濿hf?T%?>vrsW69Fee?LeV+Lm#PC? F0 yhHl&G.=O?Yu44 G?4b(N?1 roN.jߚʜVO'&(?Eut?hN,Iwe0[N^ƣ?+xrqi)tՃ$v?D./Ƀ&@F?$"5p,+?7\l@: 5G'?'GTGK?/_n}{h[?(KMM?P!w?:r/?`篍mYy?du? :?Ԏ kO 0?58퀿s%b /m I>?%&?tFjMC ^4e^uI .|?GbXWŎ?A;q{?xTO^qn߸OsК]?ۊ RC?e&nF۴T,?%ZNapbIL'/Ű0u?:f?ghNJyN?]?/~qq?yY`Nt?+UzYMrxZ:h s?bޕu?j vw)n@Nq?hH`j?{3_cogdRφrp?4??'|bU7Ĕj[!͠t? m?J|lP{xЗBe\5f?k.>?ܮv Zb5҇S?N1]Ie6c.Ew?4ef?= .~i3*Pl<9?`'yt846jvQ?DD]?f^T[NU?FhZ8a? kCmN9u0PzHt?OCAXxq[}X٥j?Di?6Z p\]nW~m? G`=7!XT1̥ɳR?pV I+ꭒe$lf?f+c?pn{hihhcg8f?T?%G`iu RPj?jR8tk:FEU? Pa5j?i@ D~_H8j!xL?QKP?g!i??2DtZCN^Qs`?”DMS?%2f ڕoP[ye?#;P&/mh~[( :?jPP?ƫN^RV8?.<rVު%IjR?+B`M? '?MhDY>Ǡɼ!?мbC<|N vF?n'uI?+&Q hTOҨ]MR?8L?!IeE@XD>=K&& R1?V}WP?C ?OoW\򀈲D/G ڋ`?ZGr4?ˆ-` 9܋);8%]3U?Xǜޢ%﴿_8Y{,Rn}?; ſ't?uvͫM|L?CTo>?x볡CO?,$ĵ=ɠ?z>? /ԋAԘR&?oZ[}hdߨd6U?zEFj?؍+f࠿YXS/ji!IgY&,?uPQv?+3~b?-]A{?ޔ?KsHDd=h響;Ӝ}?=q?T1?tSrI,g?Vٞ0{Bj?(Q@|?;" i?L]gwĒ3P )d%(?o/נ4Xi\h7\$pjk۰Z6zijS?鲤@ȕ?gtpZ?<3S| {SyڞJ>?q? u2ٯja?o~?/{&?ìz aPW?;ҹ4u?($8^ ?e]?Xd9Z*a/T2~M?~6j?HnK:,ru\%چ9.lBu?Ac(u,ɗ?hr?ŜXkpR'Y$l8%F&x|puvm?ρMPf:g?,]BJz#_{v?qo_B?+sfřrtf;VF?*![Pr%YG? (pxa?Ľ]}t?uug?27?hFeˋEe{yV?1?nc! n&\?eP%?\cvꘒR(nZ͛:pv?Ȃh0?PTyIz?vQ t?F?=Wտp.'hKl?en?Cc.W+-CKt w{cPᨪ?(kHԉ?@JiΕd:/P#E|? Eb?q2a/t Nb'R>v?__?cc5~R#] ԕIz?6Taho?9y qiopԑBxOk?,B7f?I$9MI(dW ,Ait<P?^n{?OBdTڂYA\?Phه?Sހɡb.v dH؁V_?8os? 4@@-aDm؋~2?0''VXaL>}G n?^K]D?g3#sۻ0((mr?7ǟ/ۺmSy΁I?$Y`?Cw+d9GL72F F5?{eQykvk>s`?)/JKkӵ[_e Z?܊[U?QWbLbD|k `?"ݓ5 'QX[I@2T?M R?*e`n_=/4@6A`?ȺBḠ^TUeT?=eQ?)}WbX.?~TyT?16 ЃVAͰV:?n2X+~9:z= Q? (eq!??IY[C[?٣^mY?Ѭa.4g d3T; b5?7qKE?ťe'd ; =)E\FI<M;?٫}+Q?MG'dQߚjH?8YłF?KQ#GGx?T@gt?@ꚗ/dG2{"lq]?=#R?@C_q,]Ӟ+Oթkery?&5?%5-ōMer?n ltn]R?3ZVy?Er?*px?!6;Lț ̙R?лJV}?UWW3lad~f?W?z>`?H+_g hu$(/hK@Z@?6݄2a?NNt?%6I:ecn1]ȽD>s?Q&wk@=%Bvι[@c_*|G?kUf?A8{, ӃmA{?m9}W?8ۇw?p?3lx.ks?uw?ս jMw:b?~C?9Qy y?y-Cx?U)لUVqCzOƧ?AyY( s?+〿70OL2M|ri?@+){?!ػl*9f*+K{cbs@$q+{}BEY?@~?Z8q Ks}U Iy?-DY_?,)qNߊo,? 펋s?*}~mG_GtDv|;~Sn?hpw?,p?>۸t_8l6V?ٝY:a?rJe?QǶK&dQP{$dM?)'V?R!aA'x}ޫL?fd?e=Lן^ؑuIc?[kM_?$-T7e''c?GO;X? ~q rL3?lj=!Vs?Ԃ*h/@p8dczs?[b?ezUlPDs?q1PC?ppfezk<̺#5:$">?aJ`?aF>234p,.|YZ?`Js?og5kȚp!Ko?iFfc?5 rΪa[%v!r?|bKSIio*,kԗY?_[zd?]JwTjg,:>7V-)?x-7rFV1T?9/l'b?5Vhbck1בd? 9_?OxcS- SrQ6JY?p/&?kkQYiS?}l2-0 (VhtW?O'U?Ac @eFMt^޹f?z}P+4 c4RU?a $T^?0ۺ\g^*'J v_?X#c~?1k[3$R?nM?Z ^Ζ+ajc? T`G8 2hcb|8hhS?Io5:?dY _1YW?E5PK 7?{$wnIM5UQ?m.AP?: \ch̖S@ ;`? t%Q?@WZ)'jxIWyjE?60?>?r?)L o?8DZ.ÿiD*?0+@?6] G\UBidſ4^?D!bl¿ye?JP?N񟿿PDË ?\q=P?;Ř?@g vՁ?P 0wԓT?WT՚3?$e?VL?_{Y@f2C`,q?ǐ?ObtIo|)D?-0z?"HebpǩʆlU?ڒR(?\eM?)gEBc?V\̞?]Nsl$ vz?:NYF-0$<(u-ݙ?ϳ?WϰBfJY:|r? N?R7 t?F}o? Yo?MeȜ?Cuj b`&9{?x-?ՙaXkp?YMێ?ǎ_.3?$?XI_?o\ԓ破ʖ^?h͂M?,Z4N֞|*g!?@?H >ԐtvM tI텿P?T0n?DbDodgD˒ahV5:h?S6y^&EETKܑa?g8k(g"|?u v?24zsy][s?υX(b`?bx֔f]Wͫ.?!CU?1_S0EJhVg?ox?9cu?'RiyRֿ`IesHt?2$ ٧\c]y|Tb?`?;o]mXqiMk?*V>C-xpwQ㠊f?B;s?d#!s/iO!u?] 2\?u_s"ζ0T Kȁk?4L,WsC`%㯐O?혲r74h~6W-s,`?dB?YH[)jJ mT?q#B2m?9l8RpOk-bBt? ng?ZkⷁtmrO]8p?[;?/,:`;Jce BD2?v)8m]}^?poWl )?HeCrgV 5?nb|h?@a%GxeE'T?=BiY?n=gW:FH0C1ۜĴQ?2gHICh6/Z?Ji6HN_Tlx1Y?~Y?x*cvfA5K=@ h? [` /r]j&8Q?'0ZWf?՞WΈ`<%OY?eT9qJ?ɯ5T[@? J?}nW$1=2N$_?w7qv:*^i,E?KbU?iIv:Cb6h&)?Քpʳ>K3?oXQ?*oF?gGVYEHH?>x}R?T5DԲ/7J]Pk4?B9O,?na}WW?(@Brjբ^eA.H?t G/Y]?:qB RM.?tvo?)8*x93?Q0>T? @8IRvctL3Q?öݟuh?3$M?M6@?ބ3!jW?Ģ?#OӡYva??Y@ɯ:?t?4 즿Jhk{+V?XCV?S*Ϗ\Mk? _k?k=^Wu=ӍZ#͂ ?/y^02?ɋ?J&Q;~> u?tN?{0skR_X%iH*?ñQ2 &1Z$v?i}bGSx$` 35] U@dzsVx*:+?&*Sp?q2I[?>$_teE4-]˘?ZEvSI?9t?l̦>T^?P+5p?L%z?yY?vkio|m) 7ϔ'Ɍ?Qn}O?a?mZv\x?#07`??&@^W?Mvqz?Rgb9MĉeC&?:?P93gtc ?$JLjy?VFꃿ,3eȅN9qWj?rL!gFx?$4r1ʖ\?d<"9?p7?`?h .ۈFa~O?Ek'9ٻ`?.Qc:Q}?ƹx8ʊ?ͅ Ϗ:F?vgF?{"ZLg@En?*MNj?wRGr M%t?87VS!q` ?)vIA=?=P#\a?lVOOR?g|"F (ux?4C3%?㸩BVdFrn?)D$3y?;zԯFM~LCwJ?fP q?4}^.,HjfAs ?kgCz#^ՇӭxEr?3ۅ?(z.D/Ce?-W"j?Z@? t k?GfZpߐy1{J81(q?.?dtWj r4 r?#5i?MYT|.d|B^}?/<鷚]?b̀_'"]?ijat?c*i'iM(f?]Lva{ضS M?<ݸj?=Q2kೳmb7w?2{ FQ?I&zՇN?u w?\%}%dt (cs)Ek?'r@`?ˠͻRqfM',IMeIʇCl?SgWXGq?9eU?PZDlOuAt\p?˚B#}t%`X?q?(Zq;b" oe@uwl?:==I?کL2pS&S?%l?bc lRK7"?&w5uD o-N?aF?OY0?v:@ [?k@e$?մz]Sj+?És "?;E85(cQ?gv;P?R{;r aЗR~E1'd?!K0O?o+DybtCdV?Ɇ ?e=h? ֈIMлƪFQ?Ԩ3gmĿ;qkڡ?S.9@z[ AmsKʘniD.;T_9 L? T(D !J=&K7&0I:?@]6?lｚN;?-=9Z힡ڥ?8޲B>% p9ޮ?7E(?Wղ? 'u/ghlݲI9S 뙖?]UJġ?4S- G8"v?C#؋OZCD9lăK:?i[}7??f5!6kƒՇ&t3_?;$t>둿G@vn?q' ?Pɇ`qćhr{Ð?g},%ƅM {o?1tx?oOh~ OZ 4?IH?TXo;PNi?A2t?\ZKy?4Zvw?0 TBF?큿 OQk?=}B?k[3HwRhFc˒?0Y?6 iuQ|pA]?+v?Kr ,t͐1?kŃPݎ?9!܉At}>o?!pL;[#dkÌQ|c|+_ϻ?OwW?(J7/ GZt?twx?t5'xypԎ?j \pf Ik d{?`0u\{䟓#q?L2?q~}-oBRv?hUhGWA9^?t0.sm?Oî34PN?ywJw?6ǯ@v TX3{?c\'{?_F(l^!Wlko?~;a?n8*Pc?KC7bA?E(w\1(?Um+?x?(bc?rtČD;f"n_{u?Rm??֌;]eG?JQ5a2;i8+kp? {Jq?>pUFwJ/9;b?aύp?ardqEX'{?|,I d/eF{v?ex[Tr?j~|ԖYָ]9? MYW^N{a f?Hf?({`}ad.Q?u_O?Ghمڹ O?qq?e8aIy-\cG]Il?o8\>?끕NiׄR_?fj?01yoX}3$Ub}+ϴBp?¦0}Ujskox1L?tS{Fw?6PfhIG0pvy?`p?O<p?o$s^Iz낳p?RnX,#< rnh.5\?/"U?j!- kofKNa9?(b? mrViEPI/rb?v߉8TФea'‰l?f <]?cǓfri뀄I]At?&#AġpzFU? ebe?K]^D1IIwT?Ʉ?-M\X F e>`?zWF31i hdԋr2:Q?*sBKSc?Uβ_Ơ~VE!"c?W?L+mbŃ,Z?[?EBsc^xC%9F~0e?}gEt _7 =Z?XP?;F`otiO,?S]\?>Q{)O *sZ?< /iYcҦW?FlR?A-'bh(1ϥ['d?"y3B%Csak%Q?@WYV?]V;Smq]1aS,K?hZX(K釯.@]?^3g:k.2a6hԒM?6ŕ-`?{򃃽#PLjŻQsWI?)ϫ}1"}*Z? iXC<Ѿo"fpEdT?<<0i?#XVf:ᣚJ?;6&?ɈB?KYܙ?9|~Ȥ4;?QK8`O&n< GZ iOE?gVd?++_O;q2[Ƹ?ep' Þo?tM???%l{g}?h:w 2~td?}➚_hydݟiY?+n΢S%]JI?ԨWɛ?Ɲ+r?߶(Տ.[Zl?ToT?yPVx?)ɪMaT Ii恖r?e'ӆ?R~?kCZЏСM|04+?Dh͓XcH\yQ%n I ?v>>&b`l ?~Í?2c9~Sc|X?h~ױ?67qșea]Հ?R_U?zgWTo|݅G~`G;}Tl?@#J0jB?$Lߎr?1шa?W||u×)eN.?$1nx)1㵉Qo1?X?*unik{^dÉ~??V0P:X}?`~?R#*s3b?CO?۳'%l?(v?~Ȗ}myivjv?K@g?(N^}h rY?>E*_DÑq:t?[\?͝lq{bH:y?0{O˃v?zkX1P?;W? _4eOzU:ruw?h m`ʡ op"f?$g?5cZpW .t?Xmc?wO낿 hO/b0)^a?B3+PF?T]}6?qf?.Sp? KnI5'kW ct?mfOt;w*Tw?Av?Ih{(gઆko"4Uot?$5RE?tY_thD?7AR]ځ\_+i?yC(`D?fbr!iA?x3~l?;j Ob@~at?^ȿS?!1u $kFX4?f!7cm?@4X<[d?>̢< ~ d6H?Z*r9wkQ?^Tq%u?Bӧf{sW'q?Sgh?q|抺s"-PL-t?ܙ Oqo]`mZ<]?QS?[s`&RP?rQ?aeg 37/]p?9+WYF{oL?e?`i?O±BlY0bel?. Az48J^>ed|<]?wveR?li5d% xNE?`Of9"g?`Eѧ8_)o A_ymkh?>(GD?amp@i%\HE?W+Πf?b8M^jT`c?F@ѬM?׹ nb !b%?o_V?"\RXC:('P-:W?;MQ0Vgca_?mOuF?$ aT$?Iul\[?Ģ:?M)GK ZW?vU+@^4S2W?iV?ߎ?eIð3V>{1j?QQ?F/hw8yC_~">A5(9υ??U$v Ý?Go^x?=xJ^i?IqS?qԺ)?`+;rNQzj?V-QtcQ?q:/bx?)E=g>ٛ~Ŝa/biiaIS5?+#Xil~ts\q?U`?8];}{Ka*F?tȊD)bqUyj5;i?{;2? Möe>_ZMf B8{E?[cZg ?jWc?<@O?{tha<_y? ]?%s~hTw;%Wȍ Tq?*=`Om^ΊCsHh?MvIK?F&-v;~^?p 'y?>{ZlEU1yY'tt?;("w?⛒/,rlqfϗ|~{?͈?S(Er?;s=6?I=ߒ!d6ք?d Z?<=tN?UKb?M\,m`T?2sʇU+80w710K?rMҮɶk?#n2dK-9m?Se5S?:6]D3ߤrlg?,MK?$ͷƱFd?yn*y?V6\񑿱0܄?׀Hу?D3kыσzu?)Vv·jbsSIpj4hs+LĀ?t1kaD^?%(CAAiyƊ o?Y1zq?  Dl?t}?|E)z?~/{^Fw?(A?V+eP$DSnIV?11(EŊO#Ǯ?52d?>^_u>D۫lљ}?l|R?~I{/vi?F.ws?pag3#b/B? X^?FqBShohOnnti9?|T{r?5i?N4ni{,*{p ? %kr?Zbp5b<шb LPx?G&@ؐº p?:p?5T,w-nX?V]{?"a7Qwt^b?wۃs*fBEpjHyf?_?s?yO xv"u}L׿?|hh?, @w4=QU"gCx?-M@7W`@!7\2?#q߲?JGG_+V?29|;?wnb-Ye3' ?׬;h?XλQ4(zcJw7Z?tYA1Y7+f?|-?@;t-Z?+Et?Khh8q ֫r]v?Lxg?+MtB RpCyp?3v>c0|L`d6xX?B3A?lc%XVƒY?2?U!yB?O w4c8$:?[dc?{$|`iiW^'͝|l?Vc q>NraNX?Aiu??f uh,)s 7e?޼sf?1TT`&N;ɶ8F3?n]W%^яv^? W\f?8zm|c h.\BU t?qb?\ sO# |n?@NR![a*c?Oq6? j5ɿk!`?8Cl?,T)k0*cZp?viD?.coHjV?lhc7e?+>+^hbS/:]m?,oT:WlzY?xSDzd?.m ba<^SS9 1*^?]@JڠMnX\? *D7k+e_*c/zUX?5|a?Pa)_RTb,Dc?!L`tv ?u΢^U{BT??a~P?لa%1־>y%Tb?ʻqMvV HZYb 7ˍV?#vj6?D3iYGQ?d81R?,5ZTcRlNn!6PSuh?*cZ@%&KGg3JT?~]?Q_>% 0mn}b?@@U :r; @?H|:@Uo?pP W?>2sSgd>ʖst1T,{w5퐭? @?o;9@?P;NŠu?^.?:Bne;T?I?bNcERq?Ѷˇ?P/֍?$o*1 Ә?_+gqZ&Zsk?gs9\x?ALټW?I e>?T=>|?qIL*5ҍY?YLh?҉ꅿ`Whvd!~?~fM"~?5u?ԤΕKuHM?2 X?Dh`?w}?U` 7q08>&RG_?hh#?hii?^ް|*,?33#،+xف-ʮPmGr#[mln!Anp?L0=?5{?6Ik$cb Z?QG1rk%ur?Ut.?@W/T.Te y? ?+_Tr?<L?Z7rMWs?!-}M?z!8Sri$Fx5(K5n?Rz?}ytHbGdpx?EcX?HEUD{dMe[?롻i?|j~rQT?bX`F2 6Г6ď?`}P`~>j[?dĮ"?vCu5u?\N&?. hu3np/m?t7` El?K`e?Hy#a|9(\@xw?W-j? /xcf?@ۓ{?]޴S{) |? ;sCm?zOtuwOK'V;?QlO0ySyμ@z?qɳm?಍<:+C/?cI<3}?7rl-l_Lr Z0/{u?. RxV?urb?ݕmn 5o?f9`? `wgHHjF:ZUe?aYi5R65S?Q-7nFτPɄg?ug:\2pPZ-]?2e~n?#4XpTEb~<t?I+NRgA$Ca[J~4Am?߁U1?kj1=sZ?]f>b?Mhh!E ~z#n?n@K#3i$x{_?c%_?P`9d75ELXma?heS7j>T!0`?wťO>"Ia3S?¶[?#FaW^`Aq?smd?:WDHsKbcZ@&]?qz%X?8=Ɏb[" `?>Ӆ^ZSjfRm>_.~b?{lI?籰ĈfQ0I?Le?# zpDT+[hrJKS? p?ȇ?ᮄ04da?O+hG?߽<#7Ep?F?ݗ(ʷ`?ꩿǙI-? ?S܏0?k@=&U `6`?I0oF!@R?CN g R?CŘi?hflMȝI?|gԑvc?Sc?_0X-z? ͋^T?%ugŰx?v84sƍ?uv?tߢ9v?䢘>)?8F|?R| u_U'r?rHp?y)$m \?A FŽ?.4t$[; `?Tg?=#<}m?gSrٍk??5@r?}:r?@;b6aBpl+쀿0+ɀx!e˹:(9z?z#탿\MifNk?è092h:+.N?ݯild?|9,aGt!?G-(w& (t6y_?`_`?g`]_+?R?*<ÆԨ1~jN?qQ,?u=m|pj%Xd?49J??9pw!!a(}?#uq$t?ଖrqe[chîx?U(yTj@!l?:ƾ?K]I$V?_v_w?ϾOwRD4vb?(TcVu~??{q?׊؉}@Q`cDR ?!&g8+^r?dDo?m-\R҂H5) R?׍?yBsy[7u7>"ak?v?AT!XR ?sna_je?fu'z01?QHT?V; g\DJvfJm?~֔Iol?2b D3F`?0bJJUsiHl_ߍl?U|C]]?k)E&? 0 W+y?u\` bo vydwe8q?0~?C<.I{j|J~]}?F-v?Q v itw$p2]?0/>gV?6uzwY?!g43Sb~n;I,0o?7TIT_Dvu{l ;Y?oՅi[?Lqh%1ýSo?)?X˄Eqj2;p?Gzf?dw2v~BVSE5)?y?($aAcj\TueZ`?Eд< m?yI<>g[We^mE`b\b?ed,YZREHzff?%_wZsQ@ecka5"q?>&e?xp?mSsSUy?JF[_MWfvJ%Wa?VMl?o^kvYaSm>n?7HU흁tfG2k?M?C)Ogq# =W?tFn?Ư"iMezL`tmCVp?#5kdtJnLkyGb?pCg?k;^mEѦMRq?øU$boĴMh?=C2c?ef9p z`:n?^[5|ƽ`d+QB^i?ع#??7<+pNIQbW?0?fvn?-.g_&#eSR m?AcN?㘚i˶עE? &_?!(\sP0EAa?P~>DV-[\"e?SnK?YQ&ܨi"ʄ͉9?_ f?wLJWm+[s;`?ɤO ,?Z|8ioaQYxX? ;Lf[?eϰeP]g? }:T%?x.'TbZ?pC?զH?Ceȟ{Q O?9A<U?7dݥ4U‰\?Iepךe?pk]C'ItCk1bCW,iВx6x r?; ?GکkaJ 8F?GNtq<}+ut?eL{j2I`y W? ?Z&4sA1]?̚?-kQn1q? ' x?ooM y\ pw5Vz?R=r?FYƒ!%p0@h?`DYb7z_?W[X?=;k6C? QYD*an 73P:e?#$?`~^\k /!VPp?Hq?XruL}Do?2Vq?ܟwadʋ4IY?K.cM>R"7?bvxAm?-[\г0j  c?p63c?1.d%QRzL$IߓS?ֆ̌JmRv@?|)Sa?T fD7bi[u?=>]?B| Nl%?Zёa~?:E`sÏSxS8k?Vbck?tqp2>0+ri?T_˕4cϱX'zWn?怭=сbir?単7?Ռp zm9Y?5If?r-iPD0Q[o?Nqb`Uy:kxcf?$^`?)jvamqE̽f?SO]SJLl? cGIH]&4qĔb$d?7[p?G)m=1"h>n?ˢCX?ʙXihL?ДV?/͌}JUã4@?6="]?M:]2߁`}58\tg?r{_.P?gx?9Ira?:?ٿRT3aŌJ-(yc?t>$cC [gx@\? oCg?K0TwafgPc0hw]?ADV?(m"񹿫71?}?dhxW TnWVAC;4rt??݃cY?q ~a?ײ%E|M9?>L?qJ8|\Ph?0B+9X8"ͨ5kw?񱙉?|JQU?xR UcBzd?$M[l~G2x??uC?X݊,fx:?bKeu[?`s?H^rN?LNBP[opb@[?jp7[di]uk=J,?!;4|Q``_'g >sB?` Agt?)@N'-܁(@Cy?ddW`A)n??a?7\!fK?f^&,lSLL&2Tz.Tޅ?I90x?ZWB~fнpʜjt1 Ms?O J?GupضVdSn7ߔ?eQGA)Fވ`3Uf?P[Z)w?m+\= ~Y?/V{e'sv߆?d讞]?x fC ">i?TZ[~? iv"[4vP:z? %k? =X"uz]]zC P~FVf?/u[UqTعB=f?ZmhTeATGs?C- W?4h{zW$.H?Tfov?i4Rgb~yp?7KE.BiD/Rp?A&%+V?c`gv<(yNb?$=ew?)/2u (>9tz{?DiXf?jA7d{vw2Ӯzu?DX@Yt>f1i?ǧ>p.$lD0mke?7r)e?Up[pHv|@m?a_~Y9bYp?D)Nlz t&Ob?zcRϷr?9֌bo&hE\Bq?-ܐD?<Hlg//]_?H Y?yv q?X˞O?xARu?;NBFk56:cj2X?:l_?v,jBON"ݢo?YWԶ\k396S1d?Ak^?[e*?-y*`?x`I=EL~s)k?(n_aAK".K0\?W{]>WP/d?`$|Zh@UQ?^;åIօ?iHѴ璳? T5?ׯ ?#RM[?~{}?`SE|E cTɗw_?W ?H2ed?%sx? B!g^?u;eT?C^/e?q.r? e[CYl?N9%aQO`z V'딿#%n?ý?}c5s}*9cIX~?z_6`?E?WQWHtjIHrp:a,?XquF /?$Zg?eeA<0j?3or!D??=Ix?UwlHwĔg'1Y??SZ? у0߈.cg?&3rqk?p`x\6Hy~v?Wē?\#-p}B3O?6Cqn{ ?VK t?u&&jf"OUpW?)u7:#mPh?<^с?Qmkc v&՟P??V`m:}?VQ 2l>q*Ƌ? ^]p?l0d?n<ݝ?逿SnĂD?Ld>~?uSD3.`%e ҨX ?^L?v]Axۤy(qk?쭻GK?1?-^^b?.{#h:Gdo9CVf?d =l?p:q"dmg{Vxi?O/~fU?_)ϗgXm?i'W?{~6xW?'c?f>(`̑Jde?%?osw)[ ہ?d)f?ym0_3D?=c~?V2Ot02PZ{?lr?go}vVY:B< v?Fi`j>=]dɄ5px?1@rJ;cwJ(l?P^9q?#rWU6rKt?jhaFxs78n? h?.rw1 \:`Xe?%ĚQ` gYGQWEp? GXd((qXBo?OV)i?Sr"r,.ϧx3F5n?n̘\DR ZoءVo?`U+drN( r?uQ%nr?\O`=yjjGfE@^}?הI?>8^yF9Xv0`?rIq?Ê=qL_$[nu? kC+P%`q3b?`^ e?Se}jo&C?T`.h? 2tiRdW1『t? 21c>HTouRd?NasCq?o0q a߬n7q?wkJ?!n( oh?Ϟ_?*tU. +?hcku?F6 c E:r \Cp?Korc?n,4Yr:z ?; o?c dɜ cEF!uQr?V<`/:? Nt*uI̴8%V?џvgDs?{ eD估&h_i?J?fnf0V?(\̄#W?bcyqgƳP7 (?h(xJj?"`!iYYqwdc?з6`GS?W dumuF/a?7`>G{Pz@Ti?k_1 jcY? x d?(,_IbPs1dLd?̌DӶ`#f`?CR?ڌlg2wL5fh?[؛lR/c$\ü??,N\y?w^meՍ#."$4&y|?e<3i?ầ%K@)/i?ث܀hBu??ƨnj۔?֘hx3pz? v6衎KNɗ]?6JuRw?6KbQݢ5?c?k_~S˔wUx?qemp?/+ ? u_??Yo盿}ű0Dv uw?/kyI}?w鑻f?} 擠&8MT-sIr~?S i;/CHi?񡵲e?H*mr2`@?B}iH`vk?ٖ?0>_+v9 Pr+ք?r7A?R;Z&)ˆ?~-e?mngA2<ቿ}?0Ť+z?:$밒>,:;pKw)'?&i?:Yy2js?j{t?F2|,<eg?(U8KF?7ᩋ?i}#9?cgߐ?&@OxALeْXyy?hq2??-~%d!9vvlk(?]j?^U> %]76rhn0$=̀?3r(t?2?&M{E@ &?fy?.FGIVtly3Bsį#J?K s?o5rֲ}d XΏP6r?'d?K{)lʬM?ių#I|?N1?vUz?HL[_溗oGWWsb?+?Q:,b͢@|k?ˀ\Z?o\rU_:?CQs?/#cWAi}a?\"JXfb+t?6GT sB.9n?sϖJGf?GmFe:n?ht7?%OnU`?0Ds g?+o33J>pTr?e.pSD-͎YpFj?/x=d?׬tr11QA+>ir?qKEV(͏ٓk;@e?\؁a(U?&Lj;Vt9O?͂r]h?_iDXœ\"r?j?"?H0JWseS:vZ?l4Do?{nweIZaE׉g?`,A\*?- b 蟾W?T,Q?~MGEmc76~r>?Nu e?[vI`G=L\_Og?8f H?a [jWk5E?f?/)k]/&Z>|c?8IFg(?)bo0R?X@ M[?;c`C?HGeA%{b?d67=-h?aᎻԉ[C웿^ :tKݨ j?FxisS {?{wo+PV?4X X1?! ^?S"Ҷihh B?&8p ??3$2p?j`u('yߐmH ?V1ږ?O:?+(۱'{~enw?{3hV e1Ԣ?@;{f?nE7u?B+J?Tek߁f}ZOܬ?=nF6?&j2Us?ͭ`Z$?o0cq\r?ZEH?[;/H`?u%/؉z?U[pCEH*&fZcwZY?96y?~H!VQq`¼oi?i?[ NIX64(xˌp?Xd?2mw,a1`яTa'C^%!gP?akW؜%z?O YZB=pX?ֻo?wz |Gis~R?6l݂?B/Ͽ-TVs/? 'Em`4E[&u?!njxp?RxyZp/Aмw? }? `iᪿqhLc >`?JFr5q?jhRy?\mt{vk2WYYփ?X9+H`?fAf z cMbyT{?tUO`w/>c% V?DuEpa|tK?MGe?',qMfmmi࿎t?AW;B6>_|iw?\hfgޔ ?,'?*}?^m'g diAʚxX?6o c?3n?kjTDm?{dp?`Vk9|!7pPyvu?θe?_Ixvt<[եu?g@T `iz./^`??=&QaI]~GGk?;1JEA>M[ouq˳e?ƿw?L ,tA"rsZCt|?(sh?|"y?V_Knx? ce"WHCwnpfs?X86YI?+ct8|H`?D;:>p?s`l6Am;3ZMep?q6YLzXFgUhQk?xe$J?VtS[?׃պv?Q,sgqXe{tV3lv?1^h?Gx=PIM9)r"s?HlE&UiT' f^6f?"]0?y B i Gc??*Nc? :Fqr=s?1΃[Kpk4Sl?Ao\8d?ql͸b8Rq?xF ]h9Z?Hi?h U?01qdky|8E.6ͫ`mo~_uZH+Fl{?Q"7y?:%& uPmɏܪG$7?i`?JwM҄ɚd7H?9;|r?%rN;ЙdZs5d?FYup?Q@ [?Dq)?zw**[zr?>hneIKo>bطp??{e?I5y jX`u>? b2 ATd?eiR/ϋ]-ׂ {?3TI/ $72Zc?4mʅ?pSpy{w{?54.q?vp[JH?Rj2k?Ji߮{6 ]?_m?ouizBۛ? y?o\='Uxj!`?k;FkƩ8v< ɉ ~?<3aog?72UBlb?/?IKtL픘n<0w?W@Jq?t $}9ykG``~s?۴j_ l4vYp?>*P@?;94 fv3I r?lU_u?G?b~Hrfm^K K?!TRt23.9n? S?z?F?tAܩT?Gt?9mDȯQln `u?wh-a/B?XGXWLu#xa?bM­p?oJo#^x݋V q?Mڭ`$Qs/gjݛe?{U,](B? l $ya?,D2Jh?yIns39vdU1P/x?êQ:|w>(LyKn?m-q? v͎oat\0y?mcA AwVg?I0kq?9ᢽqޯs]| ҭq?{@ERf$n?W?s.Z`?<5t?anPZq!8VoN{Av?A`?GdpvMK ?|tp?ܯi`PS`27/Pi?(j@?#0x^i8^c?G7`?klF BM6"DoՓn?H>Y^|,K~fX4k?hz5S?IqX8A?HQ8p?8_<~\Oie?%eY?"ad#D3?fL[?îI\1ވ|e?z!."bUGyhgV\eb?Tb?ΆfW G V.nYe?SѲ?nG_eϵT?d ZO?e1apܲPK#d?h9:_B! asfqaǹy-?7Z{~RNn1s?f(̋QD`uj A1??ف?35ݦ?ǝ;VwCiŔN?@ŗw?QeWh'r?踖f!Q#8k?T#9,U?-mId?F+;vY)r?sfOl?a #e^`?%N@IȪH??ogKi<0p?aOW|?W@ V>eWt\?iX?KiR>ʦp 9rm?m7a?$V}>QkFLƀg<=6?DQq?{VނQBQ$XO LO|?mOe+M_l=z_q?+uC?Wu*o9(QX?+`fa?!Ulj57?ۇCNh?B/j<.Z ûu?F@~8ۉw(M`?̘-u?I LhJk %j?J=qM?#Yfn_?f*CP|C Pzg?;?<J)ezA aO+Se?I?dOvќuU?cg?OL ꈿ^+U?3rdM͆V2?[ ?3I~G.o?ǵ?G㓻җԘWȵf9aW^̀bd?92۔q r uK: ^?m_ ?mȵ 5obu|O-&rRC[U?P.kWbKʜx?}V!X?*'z\:4@@?$?˴i…Hݝ\auFM;?˘ч?UWl4Y兿~ q?!kJ؈?uoSc{E'6^?*k?Dk}i+*jHX16?7s? ʼnnp?4zFqrM ^=h\A?;z?AAget_ɋy?\@]^Pu*{'k!s?̮w?@5y|OXeE?V+/t/~?G"醿=k-)\r -s?ڢ+c?%PV"pl~ٛp?Hxp?)id{M4kp?@IZ2 s7}Y$RN|?םHu`?;2RO*e5PɁ?9=ڊ;? K L m?:A6ۃ?+?y^I|;?,(e?q[HOd?K(-?\Cyh\y c~?|0b?ȧRv4f7W?(s{?g FyuLhvP{?[ Gg??nTّNFѿ#V=l_P?㓮pa ~uJX[]b?N=yR?+Jz'W/!e?sI`eZ&QՉvp`?dH?I q&cѻRvE֙}?,|>{?y\/I58qjZN~?iy-O?Ch|\8TX?ͅZ*q?.ij3)ȮWy Xʄl?;` E$f!c?XN?ϷEgTL[?kgme?8a8Emh WHOu?}')N ?{JEt [?o|k?ƑeU{zUR ]f?$(P *]a"ʨe?A2EC?JDMlo *K?KAg?f=j fQ+Z"l7V]n?vsCTznQge?qc?/drbjAs?-*QIBimreTd?P=l?G?ib#;9[ȴi?%:XE%_8c?Pqa6jz4f?2oIU?F|9ez:?~jP6xsg?aQ뇃|?/;c/sf:H?rRRW?D:Sya910<*Q_fR?_JC nI8Z?l)T+~fc'^qK?KTY?'~X Opi%a?9-HԮF_?f)(LT-Ўߡ?M񆔒ɛSOR??6IꖿPDt~({?(N ?bծߚ\􉩇ҧبw?&~5 Er{)uߣn?;Bš$?9{y)e1maz\?۩:['?/x?lxhX?Vx8?C[BJ,*[*P>Ci?Pțj}w?Q㛗?yahR5 ׳ZѶjֻn/? Hs?vmh izNVP% ?Guu=F4̧h?o=.U]?t$X}wrڇW IS]W&QT:Sk972?yetёiM",z?A?6k4XP?%SdB`9ܩnU#DqM)CU?3a|?O %xdT3Ɏ"yTn?Qcmw?o8xqѶɠxZUdP?pttB&ZF;g?>?j'?&xq6FPsf?vjw?J{{[uiGNL rk?᱃`?yq`sQf'k?A?>?rtu9#FY?R}?E?p9Qn#jmIU|Wg?pG,R.mgb?M8>`?^ġ Tp^oTFI?,+wq?{D5Z0xw)g?\=?r'3eI c}?p"ZBpPWJg?'&K?=gxd፩a?3bCK?)%pBM;X?\Pr?y&bq(Y:ob y?1〩c?"q3}>U<8@c UIz?׻JIbs?^?Zd?7aeHu:+)d?uXdU ۝\iP c?#E&?.Mc!k LS?.R?H'ra2?W^ud?Y woa1c?4PQ?1tgCU:j#?Ƿ3g?D"P AU]~YVb?i2QL5 4?r-PcG4U?ef0`?gi#vf0B 'ei?w-P?i4hie?}\?yvގm/V}o? i;Vp tlS &f?ٞc?w·[k5hKPkLi?CfAZXX^ MsY?hgt4?]rl`w&Y?牞_?mf{h'rTZp?`TA5?\7q?U{D?8Q w S?ܙ҅CV4Ƽd\?"@WօH?O8۷Qw)$?Q kY?_TO,PY->8 O?|(D%7򁿤aKؓ?mUy$H@|K?c/tO.k; *rŞbA#?vc$m?3?۩U׍nz˘+JR?n߆a!q?E 㗔?JrGǹ5bcs?(Bz?MזN?W9Q~v?Amv?%~ ;d?NJy?A; >ֵW l?N9<'j"5 Z\ns?.?H`gw{ ;?jfh y{O!?䲚fbE?PMrVwI2)f&e4?;st?1_Ўeqʕt[lõu?bs?m7+Pg 2Ё?FҊq 鹷_vhVN?{m;#k}?O d5st?u̗%h?)s^? _dH;Y|z`ΤJ?׵D?neVÄhJ?.oEPW?~֌(`kR~pe?z(A?ʌJ fIۜ?X,%c?HCePdYNN?ND%5~E?GO P Lٻ)?" nO?kV!JMC~Q?ck7?#?2VҧQK=?ņsJ?XYM";;CR?þh+yq?)VQvա?OQr?P?e^,?N!DS`?"sX?܂I?2~?B-Bs?X ӆOTiApீ v?E-U;󇿿qHp?fsiyC +1!3hh؍w?މOPtk?Y-ؑSe( =lm/$nT'a?ERfdub}qxN"P(s-{?sZ2|?ښ.5*ā!tǂ?y|/L{f)yVYƾ >{?Am?u"$vΗ8q8$Z3XgU}h~b?f >h?DՃJp!R+p?]- A?X7/,t]{4;GaA3'y?x;'?2}zDlSP* & ?HQ?I6{|ET/?zOvv?VNuRdCg&xJc?&?@bfX(ZZ\?خ]?(ꩅkAgAgD'yr?|?QzbXqbX?k}?/gAhәx-dUbq?:s?T$/lHBjNH:"l?b}\$K?s^5ghQ/"X?ke\W?dwjgK?wMѧp?uバNgKi2WUSq?ZȓEV?@"Yywh=?r+Yv?9Cn_GRtqى^Rd?NqJp?2/f,MDb Qyb?A?&IUyV`tH? SDrE? ,?Z*`g??/ӎeZ?x贏S@He~Q"w[?C?'f`uB?@vW&`?k>AXQo]tlÀIN?{\pS?{ONU>gKf?HQJ߁Ub Ԍ)`?P"Q?qZ4Ch@n&?`{Dj?-f HU/in"a?8rd?ݕNȾb?O\2^ha?~hA?4ISpEB B?Gel?&q>"VN{dR?Py']?EdLab]h&ff?墼7GW?Zjh Gh.+Md?Z?{1ΰ)[gy&RF?隆]G?B6FbRVe?"%iT?I CA6QOv9S?UIB?NMS7 "{b>#vpP?w7D8~uFz(-P?~L/3?˫*ΟUE+Cކ(?mBV?}ޓAѹySZkx,?kYK.l?<7[[?}p9󙿐0GQ՗$*LYk: 5ؐx\?ן##~[mH? SqO?s7}Jx@*0\?a|D?^?*;13/-8?`?vE;:?2 r#1Ȃv@? 3?RLe@^f i2?fb-m`/?FBX%?UvGMWH.?P?Qr{${莙FzN;'?q^D6?c (hv:$<,?H5l%#!?_=H@?q}.DqMF5T?( 5??E6#VZ?4:?)gkjK?q(&PMpOPV?wDH?KT?wHtI3LKEN?xi7?I!JuZ [ ?LKti>?[ 6^AJUW)?'(I?A: B"B?! Y 7%wj39Q?^F?YZ[-Bk*E(?g$^?2~?ؒv׾l\mw?7/u%t?VtV=|?]Թ  XKkT&'}K?B^ ?þV@?lL?e@m?<)z/`K|Qa~?(@S? <"d?xʧt ˧;Dwt[fOkNu?\hΈw?7&E!vhHo?Ym?x"{D?1Ho?4\MCT?wTa/-xqׇv?,;C|j?'L+)|?XdW/mt?h7sQ.`.Q,Yz?XYS@8f> l?y@d?_Tm)ĶUJqȎQ#S[?{aI ^On|WA6c^?7 |S]cf #{?\zof?Bn-H4%zX?#X[?~?ƵaY}bꗠv? C}jn.t?.Zr|,fճ.p+g~Ez?;F6+?M0:zRrcO?AZhu?B+U^MWlkh?EM?\?_ݬ+udZ}R?qz?|!`S"xHSْ>c?Ji?n򡾇`0ewh?m!O~?!mnKXvS҇s?#o?*Iu% uwdXys? J^?,"58tƥ.q߉}Kn?4pX¹\`D?E_jU?+VUs&O6e4*Y2o(0@?рb??NnP2S X?kȐW?ѡ)I \t%/?#hY? $S:^:Q4BG??&"}&&Ĭ?N/ͅ?݋߀?>+~)p?vh n}S? #7 ?0vAD?qO ^`w?XlmF72!Haѥ Rs?LpA2d?luQ? ib|6dNc i,ՆpE]uskSra M{*k?\Ystц?s-,y?GBG;#4i L2WlJ?Gk?{k;n?6sohW?0q?jEvvN"-sdf5m?H_#g?7RdYp7?wS?hTfjT~g?^yZ]`?ŃYb`Pz??7s23:⽈z*C?I'a?q~fos~6Moyo?}\j&p?]WAWp7+,f6l?آ=pr3sU t?Lm |j?nwna?\O`1X j?c =X:B`\vpe?ҹlO`?Ÿrëxہ@^Lv?%LVLS?i!pk)rd3U@Fq?a!X?8Wjp;#:\zWe?<2ݗO%Lg3/'?-s]mәPG?؅PH?_b}R kOU|J:O?$պO?-ܕKBFQG? P-_H?Y)}aL@JRmuP?Y FQ?LPj˚LSTr&>?E kXZ[`[B?A#rX?>}Oi{Yh[S?|덞4dX?R =dP<%8Q0DJNO?zܾep:? B jDSBS@t0E?<4U?&#H[T:UGRWXU?AcYM?euiU4;[L w{fH9+ݎe۱t;?u:)>7cF(2W4?-` P?!EdR|jPR?~C5T?V?9Xi DBU ;[?J:S?B&" [uL_a]V?4C?ya|EL !h/*/"?xt0,'UB?^\3D?Y8Ԕ.R,{=tH[?M(ؔUR:nQQg\#@w?8%?c6ɲg?^6eΖWgYV?9g0枿6aS?Z+Հr9vzT;?Ɂx*?:1ޘQ?ợDky虪mJ?5)q? @*D?17_?!蚼 Ȣ?"#?Mtvvfg ?uT\?c:dyw?[t*y]e-N?ePՒ?eզ8 mR/f78ٿhq?eh䰄hGcK{Hv?T??DgwyuI u?;fR?44rtv1] O?nz\UkeG8ocd#m?HkѯP?XfeCr?5a?X!S+qǗ>8~G u4Qx?ݽio+?>:|(?4f/m?0Gh?ֿ:.FY@˼g-}v?z{?qQp@0dpTf?cBdG^?qRzW?'vBWY?GELbpuWD&u*bJSDG>rƀ?ǸIKO}ƀ}S?+:x?>`.{"࢒m?;I|?Xa2tqJa??_/x? U<#ˠrƦDž?m:9?hR?"$H8BNن7PE??Z\]Pc_5|x+ZW?"jx?U$]g[ڀ s17Uf?yZMjI!?Z޾T8K2?y>B VGj#H?䍯7?j,Ied{xB**D?-VK?= 81}&Q1γ@+?T?Ep>K JUĊl=&?.5dR[S?B<4d+Na%`vD? ;SG?|P N@0T?;/?T #"WQ ^MwڣmؕX?SC۾k]LT[-&"h"H?|~hd-?6A%ω5̇=^#2B5إH?BZGR?׸NqGY)b.NR?>7X`#Z?{ycRR T_U~rP?;D?/ w.w?_r?oB {?;>R}lOs#? T*?IXnlK?^1^y?u3gƯ򯉿? T?;yiI??8d&3Ǘ?1!%A?Zؚ{cS{q? Ņ?8X0pz(7Jy剐[? sy?ko6Z)Q^ -t?#ӱCw?reCzaݕg$g/`!v?$f ?U=D\u <Jaq?3.Π&P?ޛxh?a[i?A_^ƙK=?PAEwcڒ0ZZtqUkz?BWp?zY@=}R?0tl?2NG.f#kƠn?[y6aLXS ^?of\Y)!q_bwX?tUz?_n`b?Kd"x?]hvqq{Yr? Y.e?}ɭu4J , t?7@N }R(~n+gKQ?4k[]?cMX/Ik`^[?3!|0lZA[DN?4K]1V?wQkvSU}@zm:V?X֬+C3&*Oſ}X?~_?X.^VJ?DZ,Z?&|^;rJmaTf?sF e r>i(AI?W#j?IC ^W Ebd$Ob?RU?E鞵?f^d;e?@F١RbQw[_? z=W?f ?we`KD1n0_SZZ?O͸&nISj^ X?|DE?ʞ1>n_߹b?o]?ORjERH*raV.)+J?iPHP?x;@Wc/E#?˔=|??F,>?{s#8;XEKtp ?o-O?(D JP AN/?ǞnK?xI'3Pr=N!) 7?K{%a6{A?lu<*9?^F1HL@? ?~$: +?O{=U8$:8&wLeR?},^_? _dH?nG8Q6D?X̥` CP?W'e?FUskg,aje?(yb?R%\ㄮ-[MAq?XobNWYkBI|6X?}q_?(9lVgQCQo?ǾKwYwbT?9Fy?xjjcB?wQ株r?сbr??1pykFp? a\?2!mDg͎JIhڨI?k2U?= qB0Y ?%x0?2}4I?wUF,?}NldߧElXAQ3.jk?0C4bk}FoQ P?RMn?`b`+1ΝkIVPGJk?YXd?Q-r6\?h{Uu?Žϳ:?-Kq> ;?_R\o?@ HY؊IfDeպa?}#Z?H >Sb,y W(ˆ<[a?u H杁]/rU?gUJ?ŋNX?`2SzJ?lQƈ`? ӥ3V'FUͦc?5>'CeU5bO?ua?#^~ÕKNKAd?K1ަj%cV0W?\ac?GD#!cZW# K?ZMB-F)fRZBA?pW?sއjI_`ȏYnqbK?NɑV?#ZiG@NpX8?{V2?~?>]D N33?~8B=H 5AQ#Q?)/JP?cO l W"P|NR;Y?5tEE??WTyza0u˽hQ?z5c+RB[eYY?sC p?]V4bƶ֚?T-? 3:p"vXR?n*_&RBmt8گ}lkt?nˊyjǒDb$4̈y[ !*IiAu? TJ?Ns&,q.s?!-<ڑ? oc?房NK}?VNHj?QIjr ;.v?7&v.1?# q?He;[?2Ϝ{aVsH{rzAy? dkl?߇c]pQ;E$@|?-Ε j?5F{g?Tg-GE:uR>ƣs?\~̽u?R"px'SqvvZP?a0Ya4IU?14ydN]?GN`Ps? -9xN˼"y=cxw?V>2 J?nhQ|/IT?rXO? 'u$rVU-?-Zv?>]#{$pxc?z>?QKV?]֨R!eB헧@Q?3ΞSI1zJ]FUܷY?c},HC7z3?޴#^@?R9#E"+3D@uCnW/Z8U9?JH?er.FS9?ET(? _kZ?P#Đ<]VQ*?O5O]?3z=yC,ʫaX~GV3?3DO?VO%az0D6JrZ.?ZR-i6 ٯ?&i N?; 6>XcR8y?qQyP?93K膔?Zr?"Dˊ} {qVn ?8ޭt?<pS%D?|ύq?p2Ji\ 5pI?<ȁ-iDMn? ]?3wMk?gigf/({?U|q!@x? )5c?"8LG)tX7? 9?0d"7?Tbm,!u6|(2&?(}>r?&YU?'u(,DN\?@Bo?pp \RU3}??27^Iܒz:>r? x?yg^|+;6 ?8'V2e? jb? Aڅ}y|"4?V /~?f?5?Y)wfbm|W?r"e(~?È *u?9bbIfvP[ VDk?<~D?J 0_\ 9m??j)/lc35)nSQ>?|aL _?ϛ+g?ilGo?-i6-A餓rܾPY٬Z? SH Ca?1*%FB=uKm49pJxa? ޲s?4c\k {l,UU?ihT?l~ ^nlAY9i?ک0%?eO+Od18 6?b}d?aH~V?R% ?+V RZj'?cGIR?l Nʗ S>\He?eJ mJ=7Ek5k?mq"+l?Ts+T} Zd2v?)MY?zt@ Q-QLIrQr?GEب7h9UsX?$mTR?X6 `aNzMN?Z?4)`:or@+e?&\RfHkjDdg?]c?8o/^y%Us?LSMF?DIrPZiIY2?p?VWR fߏ/d?Sj7U?'i賧A*:KEj?юQ  eHJZ?3S]?X>.UZ[%eQ2LɽZ?Mq`#!ev" QLR?ө?Qލe8 Y岵*0qeHU%E,.?bNy .W?5 L<1,^T&6? \28K?7^7=029z7) T >[UA?ydp07?݀)H㕜tE@qDuO?9KF@?*P&7[ձ8 ?؁M?&I?=5C~!{#3?so+?2Ip}8<<?!}Q? +1?#`m} 6S͇ݮT?Z^D\?>hŚ"SJ;O? <&?IyY5P6َiRP?#`.d!"c |+K? UK7Hl?LQdOD-nbn?`p?tt}h~ b4v?Mpɫ[`? tͨa0f[$t?ž9B%hr ̳sS?^C48n?3UqTaWT5Q?)K4N?se}IYb9?W8?㢿hV^zi8?'~'M]?Ň^yX)[zc?kuP?&zjZ=M>kPik?$ߣdJmuiꉑǻY?~hưf?x?cLY0mZ UƠg?JJ?VZfxc! >M7`c?r"^P&XIgս[辣XT?ſˇ'{G?S:FSVUw&?DvazR?3lkJA$yG b1KS?2╿A?2"U^5MV?3Q p$?flɔE?E-јvԩ7եF? ?Nx.X?/gb\oZӤ ]C%?H9oHy+>QKy2?Nuչf/?đEAw '+\P?a? qU/ ?ަjtW?F.l%#fWlPՅ0?ET?pB4}6(~;JsU:?s/G2?;p:VC50?<88?%M0E#*>~IՉK?^%b|;?ਡInO S2\zb(@?u"K>\b?)#(8mB!x?~y\QlDAC:v?uvpBf=M!ywISz?S.K?g\كeAϰw?ed?C){{ۜzv5HT?KD8fW{'_zv?jЇ̏?>qby?,81|Yʙ"rl9 v? ʇj?<ɍ”ފQei=?5+|?YY&o?=vQ30|plT#WIdj?vvN?jCg\ųY q?[Utr?:gti|b}}sl^?Ex|?_?\.` 9[O?4L?F Z y eY dˬ7r?:|j?d˩S->N?fۅr`f?]m?"\U{e\bYTُbJrşi:?c?D,H`PL?B!n!=t||Jsc>c[?a?dLre "aU6\?1E;b?X]sX^yi%C#f?:װZpS6OehgOOd?q-iZb?0|n`0m]l_?:a'̇F?OL\Rw(@?Bi-$P?OuhYj&P" D4b?]I*o u_?^8Zp?9frkX&i߲3o?Ab?~*>tmcZVD93Is?#<7? 'msJB?/Ŗᘔo?0*Pê%oDiYG;U?DK-b?Xu#XTk9dT*lcU?=b1?sd,޴=g Ĭ^>?FU1:ICAN hV?~(E?4P+_a6D`}Ba?_ՏS?[Ec59?wCc?,^RFabl[?Ҝy[?@_$ } nQѮ0H\?Hsf>?kbSub7%]K?\紟n0x\\BׁB;?NZ>s1 YA?KJw#?B{AHgPʾ PlH?,P:m=2D!C ?5Siހ?$m~=3UBkH!_?OgqylF= @'S?Egl?-TJ9s?m{Dҳی?N؋ ?jpu{,~l,+1?q(ZNZgI.}zr4a?#Te?i0? t/aagw4 .?eD&4s?&AvZab>4{'l?$5~?gaº(PU-]E_jr?߲?$73t jy!m4eLaz?vk[?-mh skH~Ei}^gq ?'FEr?w=;s?Y  j2>g9 ?Ǚ3e?nK`g9]MWӦZr?!"?.ggRu@\2u? m? ߫ra)-e!m?3$P4?p;f fU\?P?z9(_s|&D?Ap?M_BVVQh7Ys`?^~HBT? j#e'@:>JgCp?B['2=)ON2#?Ԣ;U?A0'P*? :FAFD[XX:Q?wHY?IoJ@n#]AS0j$k?"\Z2?FZRM b` ^?ta\C?*Y e>B4&G)j?V?)}3mDĦ ]s. "d?aYyTOd=I`DgߤR?j$£nf?6Ra8hC$]c?E`M6Lg?jC}Fhëh灧MZ!f?d =j?giOtݜh:fh?m%c?3VdaAGL^L4a?XOe%?_p*a 4o{aW?P a?d8e0ΗK4,&%]J,7.?'Q?2mA0erK`Mx:?-f c? ^J9Ix[b9 R?kW_?I,bUxsV*T?Ŭ%WL?INFLY7D?I:11y1ާ8.@mRX?t=d&;,!j?#&!?t* l_ w!(NP>OeBo޵!?ݲ^C?a"=?)FX{ ?Ԛ4E?T/ba`uE+(q2]?^`XLH?gG,i> A#>r5? ')?6]1)hScU;M?1>?8qU?_jN;0[=4;703d9?l-qf:?0r2S 7&?+$?Uj9% G$?Y#?mbCd_S'/lǝN??kzh.?nw$,$WT?ilq?x|?3>< !??4X!g? q4]?7|BR]6PQ?V#`fFԁ9._?d, ?{MQRxx43 S?:4g?&&nk?RPgBaK!Wo؇a?A/}=`?tjeeKZ;e?5b?nV iMi1hW;TIQ?;ܩj?q,CXY6U2b6BR?KW?ɥ]#Tdqe?_-I?ShwKY-?9{l?LRI2oEY)]?xzװi?-#"n`h͝Lj`?_a?[  h=FOTovk?-/~N?*vl=]4?׏~Yi?#߈/KdaCcrS?eLG?mP!3F?. S?7.aLR_@D0(gyHl?AZ%@NN]@p%oV?8;Jq?4`bqk.dnvw)g?oNbi?5U6k?b_l?m6K_?vo i>PVu*c??E?fy SxoP5d";?ۯkSt0?"m:4 ?r?m Z+;0?RE?ڇľt`:?ʼLC <סxo"Q?WW"?p( SC/?}7P?+S}&JȉL'2?(8C?W42/0?a"D ?kJB/ @?I?.NAp( ONPZ\$? RS?!:T1rdZRvWi//?S#O$P?[g0O:MY ?/M4(K?v`>u66FlїT( oN=?wJ'D4?-#3:ϛ76v?P&.?JSC?uW 67}J~=K#*qs]>r=?i X @mA6@澘;=AC?̀9?>7^={"?9$j~?/Rt|o..c7(v&D-W?h`IBgun?%Q ?moEi?sm+nd }wde?9vؚv?iyIS8s9쇿%kY$a$eG]}Sdzy?aEj?ّ2yKj R<q?!vj?*ƘjHb1FO-ΆI>e,?&`?!0u>rR>eDf5h@7`s?I搬g]cc;z%t Qh?eNf?s* zڼLERUÜx?)``8uk?(8+h?Te1ll'VD0T?])(NY? sY;nZc>I[?7Fhc?/WHm aLm?sG! ?>Ym5[^>[_6p?[*NqF4'ovg$D?vl?oAI*?bi,/ \5!Se`? },}a?/IoP v`Lf: ݾNJ/t`?2;(?+rK`A?bed?ߞI*kc}AbF?Xc3hc?`}U,JX&Zc(`?x;*R?v=,TgksJNgEmh?x5fE?J 3d}v&?֌(/b?boi#KU7//*OaS?0S9MzQ-O M"?Io M?р 7o;F>t$S^. 59?.@!?kA*{D'Cs&?-wq *?y?6OVv?Hx`}NP?9~D?[" ?gi? k|hsv~:QF+-9=4 87tQ?kTJ?Y?hdmb;ҦgvKR?:@ 3E?p5kN n?p%7bg?sꫣp,f?D*pu?eBq6jh 'k?"`^?«z,[Prj1\c?پ>?,pɱvD?'K*zMJ@AW?Hk?z`Cq`?pÊQ?]3[)0?jU2#Y? )&J6t!n?D1[? WUx+]až~؁\ϒZk?j䶟E?Ȋd0PJEI ]?K ,D?|Jb 5Q5sW*^?tȏ&P?E0K_ܳv@}!l? 11[?T˱Y0?rdb ZBD `?# #AH\_w{[(ZڈV?׫l'?ІSOE M-? uf8?ŹD[?$^<9deVjJt42j@?bUDO?GEP%bWU2avT? AL\?;]5)I\U'P‹b?9KY?(0)Ce=AnS{ mf?K?┡eu/8Wzz\b?7?nF^n@ ?GDY?O& \֮WN[I ^X3F?6{gB?>]4EulxO4F?$xV?1𠐴Khy\_O?I^?vS"\4pD#S?C5BU?oPs!GH΍$I?4?k7Pd+?@n}>y5xط~>?HT7?DJn@O/K>++P?v ? goMtQ(AQG? R ?eK_%>QB߫WԘMHP0?`Ip?8Sq z, ?UZ?qI+:>^Э??H'os0į̌^݅;|5Ln?yj>͌(_;zL 0?)n?戌8Od[M0?}fmh?>C# ?'sA9?I K`?7Y]OODC?x?]"EZ'x"#| fRs 2?|?^J?XLZtj<OWmcC)g Tdw)f?Ȁ? rˌb>IU?=̭q@N?q ?cv]Xge]?Jt5j5d A<0]v4-QYHw?Z;ު(P?Zksȷ6n̹ďt?.v?{wB0z+l?Zt?cr¤rjy+i? ͛3?0juf64?Z7kN0X?y[wEJn `?0䆦r?[2+si9;e8@grƽGib? IJ?-UEAV8mӢ=?ڕOT?Yw  @? =ӚJ?y{A>YE 6U?jw|(? d[7(VTaC{,? ] 9e?"C?ihFTG(B`?a?Id(6?)f'|``?hRg?bGWf6ObJ)e?5d?iqi*~^SoUg?;? bo 3d`?PU?sr=]C CUx\Z?r8M?Z#Z-3(7? eo8?=_6Ec ,;E1/H lV? 7?>zʭP/EGP]6?Rs%>XE?1:)I??j SWsAOܤ0DOS?(7\R%SV?SG? Q"TF65,rM? ";8k]*;?z,h3A*-?0 ??5 B7jȹ\35-hc4??(r5?Up۪*/ΨFm?8%[2?I/uY12וs]i `sT?.Hdހ?m -x?Z@\xuZ̶s? k`?1mk&O)Zl?X-kwq?GEv?Ƕ{p?."OZCC?S!CaPFT k?84yW'MFM7e?~ tY?4d9P??YcêsW?dr9?ƣ=8iߛ#;?{E)t?Zvya?9.WH*igR?o?# JPg?-C&q4s@LLVP{~mW_hq[:-?8&?#iPa|i1_O$dt?p{B|Eeќ)Sӛl$2?LJG*eU.P%Qp&'D&H?֡X|D?hhXT[k_\ZFUd?V WW? 6pm !%aE"n?~,P?h`:mM?!W|%t?g%8c*:iKMOg?;tCEE5[sa*GW?P?\o`š[ g!-? f`b?N^lXfRph8U?9ZW[?/Du~P$b"a }TA=[?y{{&1?aU[Q;ę&?W,c?O PpG"_?_oR?(&)d//?`?R$@ch hb2E~i?Gy%P?VOsl3BAO> ^h_\g?/D?m vmB 9Tz֊%m?PhT? x"bf㘝UP8iX?M㻁A?"0[p1?m$-v%FV/6?:HX=]?$+?16h]ſ{aC$ ]@Z?+~Zl&F?šR$O ٖJ?RsS?A`}(G" .LP@h3?It3ϪP?Vtm6;OIe&fߞ3?oiw;?o5D"u=zM hZ3S?ǔO?-Ck8]'K"K\`?@-9?ҿou`~]?*(>TY`J*?_?v:dNN_,E?&imZ?!<υ?>AX NЮy'?!>?S>V /z.JQ5V m]Q?+µ?.sZR 0&?К<_?GqCP@r_Xb)3yP?~[?9i1T)@EVࠡNU?o UP?rOTy$AP?0_p*?vMC`L/ ?gI ɏ?{J<̳ B iOBM0BlD??51x2?cI2[%[5~/?J89?Z-wo龩RzD u?u}Cc??o?1ho5kQ~]f?v?Ib?"Z2~E?s?5o?u sm?G׌h.ju?xx?:jѓy?Gw21tbJvs?3@ m?OCmdKG?WtPR4? d}?T@e k?A?| مzIEy%Mتmt?bg<^?<wE?cyTT>E?ók?~˖1un]N9`k?݀7z?žS&QڇͅCp;nY:P?Kt?dOsh`cwK,js?ghb|?'DY`VmjBzIYN?f\9w?8^3\1ᙑ#`B!+j?4'Me?kfkhH%Ih]?Lo*dH?vFJn&4"TVsqJz6+?,g/) \HQ?ڗi-?gha~I SO/tA*h?o+b?ChRxZ0A7f^?8e?OUȖr`[YOxS\?@s\i?{`4Pb%.{c?`?fb2ZؘQYqa\?;E?tY@aRe iIY?QVUV?w`'>l[~Z?Z?`a^?UrDž`9YkZ΂yY?<*,?hLCdԳA?(Р%"?^MgT`"?Q?ךBz?CLz͐*?& ͉8?X?#Ȝ}mDe}QF?n$;H?*" F^f;::%E?DHG?dI@R>n.KV;r>^oMMzRz0=s f(R?~3ֳ)?w{}QeSS7!8$S?% h)?XB *U@\N1?S\?) Hxz$_OOP?Az Z? q|RY,WzS?_ˎJsR?]:XTҠE@]*Q?jG̀(?Eu\5U+{lcZ:5zJ3?a`I?EE͍ V]RoיI?u*U?B%S4|Su^b|X?g1I?,9[p= 5hՀs Z?e8 ?먕ʛV)* +?d\S?UA+CLOwEX!C?דv?bL5ίL1?΍?H| }=1?I VB?֟+CbfB^O?@B@??qSSK[(5.bS?S]w?6-O Cב>GP"AE?PJ?Tҵ279(+ B?U!m?éDT@[?i>?#CHShdצ⃁Hfr?]W ?܀\f&~pG i|J\+gclo?:M~i'+~)GX?LgYk?TtD?7'h? U?i` H?/r&?~#D r_?$qf?i۪@?uզ=bkp?"z?IA7s)]@]s?Q]H?oͥJwZ{q?3?(άy%)PJ7?2Lqo?2y=8ĝW?W'l? \ist ʵV].i?EHJ?UOM_u #?an?m =oS"iz3hom2j?F7Y?$\t>TR ʾFT?SPۣZW.ScH/yüa?txY4X?kM&,f,{KC? NxnqM? D@2H?D(E!U?;\h9]Pϼb?Ms=F ,aQg?rYU?A,Eq|hn^u?pq^Ra ~S?KMpP?)VSxK=4!+;? t_VM;E`?8.n^RbYO}m ^?dg/Y?,:@5?bUNE?3C?C@bA9W?؂Ԡj?{Saqi;b?1d?KI_; ^{]i[?I ܄Z?X{;We~W:fV?zZzW?.Č]= uZFbƅ`? Ɛd7??h\T] . 2:an(P?v+]0?WB1Pa3vkvB?Ј gCK0*ܨ5J?/"4*ɵ3R{1>? CR?oDIB T~~P?`LyQ?4U'įH() Z?M<7?XнJQ hiLAގJ?*7gp#Nb>_?'=7?Ji>U C0mr*J7|i?%[.H? )* SUЅ1=?ZV+!W?Fe^GY0?U>`P?"V?%{IV.)&S,F<ۧT?9F?v 4CTI%+>7YѕM?9C?*ͯz<Г?֝ ~{$b_-?Z#8?!v?R BMshP?u"u??CLdVWRI/c>B=Y?glP?{w(>[1(?B`a\?yD<.Y-D?2ECT?-Dbh wK"xA?#I}6,{4?GO7?usDCn3.xJ?Ɔqƚ*?mRVKOKus?B7F?X:j0vNr? l?*Oe1G$^&:?ʊ[34PX?\/Ke?ń?_R/,c?иt?G@fRol/ \ S4{mVT? gⳲLtMX;v;>v ?@m:d^c?P3ndnJDˆRjnx?xO?$7tig 3jwx?'nҽq?)$fnZwz2? q?n+j4i"vG: !?z>}i?t^W? M;go6#bIlhl?T?P? m?_UEzqb<"C?ph?y5?yaF2ˢa!*{3\C:b?ֹF7lz@;?y9'(X?aH`M3?8%6 9(e`;?V8X?u\GRzYn?7]i[_s0?@AE?5=KVJߦD~ xNvC?M~P?)c]6l4  iKlETaEWJ yLQĎ 󍨛FEyk?VvkY?$o2?H @UdI.& BdMh?KWJx_T8A?&@U?q7}?nԚJLS(*$O?N"?jxWq(.j%\?ZZ.?v^%Z!.O-E?XK0lI?eT )8.N?F1LNYZ Q?绰J NdWL?߀$S(@?O/nU(F?O)N8is8xѮG!?:99?bJ?{b/8?s^8CDkD% E?pEݴJ? ȳP0'ўCE|;X T? 'bA?;wXST3#RpWV?zBM?~S'c|/?/kL?N7Sn.AƤH &?)kw1?W<'!?Yl&FT̂Ar?t]TK??A{>lC1Sn=3 ?IB(cX?G峊)PtY DطCu2?mX?29W:"<UAO/>?rW*N?te\:5r@n3?\.%?CxV;^?PK ts*jRߘu٣ S?g:y?E?>뀿Xקf 8kߑ?|l?( >ցlqJ?1@o*l d!P?3)s?pHC?;a:cN?V?~Hd?~jEMզ@J.q,?%cZ?ˎJ9EWfT?a/LS8볓 Y?[tF?derSyT/>~d?Z.7MB Md5I?N!8?ovC>/= CP?XuYH?=?!C2Xb_YW?11W?j}aҠSp{@7]^/B?.̋CE?dDiAΎġCM?nnуG8c&7B?~%6(?iA)4-ְ1MLTE?;w(J BlFKM3N?ժ#?#4SXD?uǟ_B?TX U&Mg,?#~#aKY"<5?1D? ^DƓ>?|UO,д։!?!>&`VR?(<%?24S/BI?QR?,Q8R;ENA9`$qW?uz B?S dGX48R?HZ>?zOHZ~ZK P#7;?#񝁦1? e]Z72ix :V]?/x[~gE?N#" Q`i=&?5(7D0T?ύx@\UOf}D?VV?żf=G5'U|jG?bPgKQ?3'RAn`I`#7?".=?-*a!DC"˱%' 4oGP<_;?,^/)?r6D #{#Y٠PG?YS) ØDlI,?WmF?n6\t3B%*7?Inc:?0hO5A}?ϗS?w;?* wl&s?R>l?7g"y(NV?_>q`?wV{^]whL(~;_?a 1?(Yy 7,0yNbT폳Ha7定vid>Q>hr?ܺA [?}:M~43f?̆K|?gJoq?^^#C-g? madHG\.=F?"ד5ŴK[[\|g?R⭅8~2:?F4O>!UD ̦7?jn@?<2>?P:}O!V?Dn$? {/Sc\*A?5>1M#?z5?R]s7&00#!4?BF?}g7|(P75Ԇ?,?+RIV?9P>?x$Vs֫LB?APuOP?7 ~C<!DŽOh=L??lL?@WZf FX):Y?>%>Y~ir ށS?i2f2uJyq[:?^>A?UkE#+_@?ʥ"&?x"Y2V_@?k@־赾CwDXPdxN'&6QDL?b)D?RhFGu@,GitC?PM?:fUҋF;G~ZP?{G? . /L?^JUظI-bC K?M4{?C?bLZ˸7g꿖8H?;l?"+l~QC|7&?*4*g%!.B\ER^a?m_E(X?/k?V?-lOqʤR iGF?yj?)`.SC6VSM?ծP?rQDs`"^V?\4Q`?\ZQ^V~e /^RgSܺ" ea%@>aA0O?Mr#O?u9kx7b6?[!FN0(R_gdojВA?*R S?NOS#AJKc͘;P?bYL?6P4& E;%O?3q:?=E.x ?Inwb&+ܝ ?we{շ6?O6,.~K kD?VO$z wכK-nj!?\=H?YHS?Dz(C?KU?Zj|4dTl 5?v R?8p4:kA~OX%fi?ЂGI?ܹ<?3|}DJ1ۺ5mD?=O)9?h|BdDkM];EFNF? u@9?b,?J+g]3u\O?Nv0H"?=P]32ID߾N?c,tp\G9B\2?Q?ZX9by34vX?v EZ00uEvP?Il]?!]ۊ'58`l=M)? ;9hb% |ܹ#f?rk?Om?S{\k|%{?;0|;?eIvz,dh.V?4PFIx?!g3^?iKs8?~z8)ٌߎH?eaJ?B"H >ӡ%` "zX?< t4V?8g8Z6ZRb;3`?}Zn?wEQ)uCs>m?rhz?(=iJ6lמʒn?`VN??|n3i*0b?~{Q”SL?~P?D z B5x= P?QAbM?)G?Y\ZiU?>K@te3OLWý&L⿚(]?58$[?IoIeZiN?DOK, qW?ctS.׿HOY"rB?y@/Ub?VW jH7lTssQ?h]b?Y*i0(rdcQ?y4??W\xG}ce8#sE?"MW~C?0! *d{>Tw;?w["?Ƙ,vgK??*>.>oHU4?v?s=?٘.?nF53ȬP.?,xBY?\BB?.SnEOCq<:T?zkP?yτdS-Nd3G?$>cӓF?CGSu󉎼3?lApV?W| 8?*HAf\ŋ"2?ttR?]^%?EɰLt1W!AUO@?J?+{@aʬ4Rǣ!?LK?3|n|!VZIPD!?oBk&N?i@:S`sȁN\KIB?K?:r.K=$z҂{EK& 2?_A?K{ܾu:X?J)#>/-_v>?2Sz6?4J65̕hU?K4E?);8[n/Cɘp\?Ø0?XȽaWu^`0lF]?◛)H$=Xd07?7P?DF`;u"&RZFars=?pUN9CY[{6?$߉ K?dM8 [4XC.hC0A]?5be-?6gMZ΅`^DžkU?e>m yH1tsَ$?=ͻ_?sސGmdBIX?m}8?̜}?P7>J-)!?؊c?4GyZ瑭,`6 YT]?= Y?ڣ[TP aI?W.mS[xA?e#.?F-cGi-q5`tGjH?c e;?4)PysHgkQ?cg6?MUè/?=ɮU?լ>|0BXvۜ0>u`?@0uxRyad3?|Hb?q:*?m2t^ B5r(j@`?Xo/F?G\O.ҹ'9Zy9S?&&]0?#LD.CQ@KR5@?þn@?f4 Jo^SgC|E?9A3RD?C#=9T}+#KB"%%C'Z?F(!?1h1[@sK0?h2\W?Xl< 2Ν;V}}PID?є5R?՗JKbLb&˅N?V/C?v򀖽N/ C0Ō, zK?Ɛ?5ap2@YaAaC)?RD0?BYbp?n{(A1j^p8S-TL?af??I1"SBibQ>ІɨUU?V(z29?bzB-2VL{-J6>"S? $'5?ftuMpgM25̝B?O|T10?`.* 3Ff?6DGr<g? aTd?˨e`ү?M?mPji?&к|Zn)'шir?Ra-!ԶIr1ЃQ?-r.O?LRl!fI$9F?25FQ?+N©?? XypSk),zV?Y?J'XFKDRUl}[Y?{;u,\?mϱAT<'?)RȞ+R?(;@? ReJQw5Z?aFϣ#dZv?M?. ,Azf?)7X6adǠ-GQ?9[?@QN`cȻ!B<.?=ac>.y+^C?QG?!x8lh Y6D ? ]aGxP?6X2] JXBTC)y%zm_S?B%?5gGd>;g fB?gTyȂ%/b'9?Q=?1_HuNs_L5P?-E[D?WʵU*ַa@"?D.uRyR?}~C?_{>R8UbD߽*gX?<"l8?a ՝`l f i0\I`?ƛ)~&N`JJ|H3L`?7mK?io]p/P>$_^?^ވ|tbM?VwVXn4KJlPR?P\xE?ZeRIoFzגO?U`qC?$q0EDFAZHLSz*?6N?z$M0KG# 1i&?=?lL<,a) (-,r[$ǩv>>?s,u9?P 2NgEWNAݏjT?wg>ݵ>?jRJCUe{'?5Q#V?~[B!?)mhEOUpBPC-?SXpR?ru DL N)ҶN?sQJE?ߏHUG9/myV?Ǯ\3?` W_UIs 6dLZS?'N\=?"oNxFE?9WO?׾O2mmNRI%Cb~.T?G+?$mK4bUjb*w+T?%"?~P3 )5!t:f.9?TR~?؆Fr_^W{H?F?e+v?rb3>T?bOJIqP?-I`?n6ʉL=lsZ'?ζVG~?(VtÅУt?o6)|?elSN?e#B|9RhQ\v+Y?;<8V 5@H?wWqc?P7bp?bikf?AZ izP6@ק\MHT+nWıCHA_O?敝Md?w:cD.ˣnE]*p?!X{e?b.1Y{.FbG +\?;b?lj%'?̈́` 0I?u'd?6P8 D]Z?"<\cG?#gPF#UD?% ?gsB;CyLA;p%%kfU?LX._Gɻ+061D?2AV_V$?R7Q?mrB;9PF6s` 5_Qr5?:S2i:i)2? /:>#3:0^4u C?DmE?!.uzL +IUUQR?M~ C?p15?<|+8)"9?ݥ1VJ[nyI?:"N?Eg*P\J_8?U`1SU?|]e_A?͋^Sv?C"%^?EKR?br`ߔPnu@5]?5pR?sf2[O[qM8wC\?7VQL? x \=Ri?RWb(_?;onQ?c #1?`ƻSMw +\?~lLA?HїaZ?'?Te X? K,i1?̫CR[3T%QƿI?c)?e &?(7H!'K?V&9W95EFuJz`F?TҰH?mRQ ,#-F$U?ZJKBE?acSWW{}tA1ҬGX?@%@?h@|iV&CUR?dvE?<*`NNYpHʡ_׏IB?_=HJH?潖2A-VG /e4 Km?(vSe?z>Di.ڈhd?pV*v?;:`g8"%$ce\Nw1Q,@'Cp?3S?e [-jεxXX`.m?':E_?>l6dVu53 g?,h9MO^Ob(*k"l?&a>DDeA@? d^>?6}K 2}f.?pUS3IlP}C?ҝRm _ViF?_$b?o\ͻK'ЫS?}o(ӾY F0+p.0/H?qiL'ZΑε`-,]?GX1۸K5>?@fXG?#^|BQ(( G~\>5?lT 꾸轄?M}`{ d>`R4?T*`G?OySZ*0N$_:9&6?JїR?I*<Q@4>?2okL?b#1@>܈B)W^A?4P)?#׉]2QaD>?+)?_m̶y#qb4U"[1'o3mt@?tU/?/!N4\d 8#{ެT?@Ҁ?ϚoQ@s=C?M 1u>#`t?M\g A?cS@/F=|7?ȤOL?oyZbF*wXFs46H?zZ:s?'c/=Z,P?O^^S? lUD>ss12?SHw5?ef)/UoyuF2>sf?l3H!?B_0?ᖆaf*?V:pA285x }k??F+]xh@%3?=rBH? I=W'B\GP+sRE?B1>fS@?^ȶFZRǿI@-D? |[k>?h4(?5@J_i^D?KɂO?xYG[uS}UP?o[NS?4#.KڋA-T;J1P?̷>U?BaL,sP̞|U+2#!E}S?*P?rVCJMEQ3X?y-6%?!X]Ŝ7?- pX?"ClO0U.,3F?ZpJK?cY@}A-L6?ȳZ-?C'> '- #4>mY٠oF %u6?(S=Ώ"?L8BzB:?H?LzN"!^W#Kγ#g$3?HTəL?2K@?-RMFٮ=F?LlUK?тM9Dְ P?*+ ̎:?GrEOsi& *#`O?=kQl[?LϧL !t |rB?w.?*64d2(RE?b>?-#?L"Dukf1gW"K?q0A|q/?[M!yM&CTM?Gg$u?N}i?^b?H7襕u?PS7]Ǥ:{rheo4\#?TG?6qau?%:?s?uvOmwSAt_vgG?]Ds?.<j?"cYK.!9I?c\;?U+TO*?+LS^b5@,n?i~5S?莖I>QvC 9R'38 r2O?O@ω8crbr?&"e?n@g*=Iq+e?aai?EalrfQW;3r?TR<}(sh/1-]`?'j>HZ?TsiA !KM?$dӞ$F@`D(P,D>2R?|*n7+??!܄BǎF?*#1? XZlCO?p=Ib?*>YR;Q9|D30F?3Gd^?ĝPYgPǕ@^Q?-7׈3–_B?(BD?\{CG4:,f#)J?,>_F?I `OC A2'HG?nb qD?{R?|V~B@qDN Λ$.'Y!_[?וKj#?B)Uq*d|>?S?<\s?d1?ЧyPZe~9KA??[EWS7?PkWB#`hG3끖kO"S??RZ'H?SiCcpF&nD?c#eB?p BK7~3|e;?dmPvb"? fj7АKx0RY KuoXB?4O;?:Ƅ}EAiI a% 1tʤH?#Y!/MfUu7?hK?@x8C+̲dE[gL?tJat@?Z,(RQ!<DT?v)L6?,TMld\&JNazQ?V}m?✟=nK Ä!)FB?%G ?ڈ1xۺJ(2^ ?%e8?~Uyked?TjPRNcDZ?S6s?t# %?gDӯ_p1tm?bF6pudAb!un?Y7v|?+cd .LP r?b[_P2gxp >?cj,t?U w31`?ÔWq+2F5h? )k_Eyc/XC? >&|e[9FXyqi?"Sp?ϱrsz~Z?1y;@?YmI÷K?,;GQq?yVRa^#mZ?R(B`?#?RP]3 ?T_-D?1D?*,S^P,WlbC?-Ƚ_E?~MS,< B:٠WD?LCy4$?`yhD(1}+?rC? -?5S ]Lo!F,G?iW&^'L0[K?zw~A? AUD9e~ԒO3M\5L?{ D?&@aKX?C\(?8m4;?(3j"?H"q4%]av0?sZ3cW1,+˝=@C?sg\<5IGCJ?vA?g>?te<D4:59)4/%'+*I?B?+Q2C(% AFgcHP?Q J?YrʳEU }sHQ@?oP3?,6}r3rނ+oM>]!ȋPMg%?Nkw;z/#?RK5>?P~'?ڊ??wsJ`?W+2fB?>X.8:Nj@:~sվ̌1?sR#i$ %>|:?cLKzw1A;8,{*E?~9C?|RIvzq> X P?`Qʫ2?zE1G_,UO!njgC?^3ߊj:v)@?Y`.?90 FK%xhݑJ?(0[?_mlJpFA C>;I?Wa}? hFr4Jb_D@? y |(R3ˋP)?Ht2?zK6䋦w2ږ8?iLZL XXB2^č#?ũ&%e?hgt>3W>+?7< -?᤽{=XAIlGF?}+e؄/HAS A?#\K?i6zHaV_m!GX~5M?b @?Ղ/N 1h1ywN?A>2$6pMjc'?pI?㭜4ywՋţ$O(`W\XY|lE?J|Wn?o{m3M0 vq?sO\?V!=j o҃aq?-sdk5l0J7$=p?uJNJ"AWzJY'8NSZt?u (m6ϻ"qܞp?_nf?*F @aUQYΆA?JTsZ<@}1?aTi?u6TO+LA T?V5~Xbϑp`4?2 ?Tn\{U?|j' 7\"{2?&(љP?w?Rh@?u>`*vZUK&??E?ŕg*?6 fON~žJ~48&TP?؝u#"G? ->x=nDHa I?\?JP6 kSx}GY`g.tQ3ZV? 9A?jfSMXuP XS?Fϲf ?7vxAS7?hh[LI N=]P L?gD)NH?zk=`LJ E/?vd5,J?w/-Aֆ'?5uC5?Kj. >,E2N/?BA4?S2?G8;,J9tL?fF?%)291Ul%7ER~I?hw彀#PѢ!.?? Cn-1P?ɂiON>`[фʼnSM<6?k?P?C=@T[SDE?[^I?bF2|?> bUB?96F >? CFFr u>s oF?B?B:>̧c6M5 \7o$];?b ?W(@+'!$^'31?U=4Wx+?d8JW6?OF_' r@9<͛?H7y9?eΆMO *4NՔ<?]:C>3Uyl!?gDM?Vj'0F y}3? Һ?QJ,4gs?% $? %f(T<_G|(?u)ޏEXp 11*?U\61?Q$y8sN-)??ZɠCW <^r0?K~1?Evm@ #"[hڧ??505/V >@?q#4?Pl 7Jp٫'ѿR~YM? @ ?`I?m'7qr?L7yl?(Ƒɸa? }yefqr'4+5v?y.%_ͧyrLy$b?$\[s?SRI].vPG~^_?=`c?X-,AYI.e"m<+zj?HUu?hyx`I=Ej8 RQ_*ZI\?JĭMkr\?.aF9F U6SģrG@"gD_?-/?vsdؚZ?{g$|h_?QwbUX' t5J?g@?q)e^]1UO?!q40g?Wg)eW[_:<?;K?nMfG?ɼ\ؼf/ Sn?|I>?mEGeA2v?[{2?u ? *?+On_KJ(Jrz\T?S3O? UѨ)\N3?Y$ 2;UZ0[?W [ݾZLSNo%?G$eQE?bD&w!-UB?n4!C9{`G?c^Dr5]W"3?F..@y]O?O4: EQ"p(E?6MD?(t?F)V~6?ܾBx姩eATFJJ?KgyC?G7Rnz~JcHy|;?˹s-L?(xB@yzH{7 7?0P?{$0GlUQh5?BQS? _" #7TG/?z2V??@ܢT=A݁9?QP?$,DF,JJ.?8f7}4?@7yE@()J?ա>딁,J0*1 k\H?>oN! ?yȧ7y9E|R=,Br?A5IgT?NLnL?vGe7?]cFLu|,dT[po?_!0E9?pt9?)2B(W>5E@?i7v`u־]/քx9e h ? P|Cc,?a~/I/>8oZZx?og5X?pO#&k[?[sP?E]Xe?`'ѴGgq{ttnWY?{\v?w͹!`ѡgk+ɓq?{u r?,kA`N]e?l?X0 Z?Z ]kX/`"="̙yP?NMH$?A A$A?B*T^c\bgn`??c?n>R!9h[?gAZ$?E>_ic?/! N?-c@[29GuB?2r?ۻIHE?\> Yc?!VN PZ\}]?F! ?"{X L?Ғ7bDS`!jM @R?R]{F?לNdOap4E4iAg6?JVDHG[A?˯P?[|lcDhGR"B(P1 ̥l)8?& :?*"Aa\>&zK}P?Q?ڰa43>;evt;?|@?S^F8p+ 3ca>Z?n@7?t; }G8?I5=ãS?Fug?2;,Ib /?nj@?~<9v#-9-+WUk5? vIo:?|GCY&3B*kcH? =tE?Ә^L(BB}c0N?R\/0n8?f OH{WK/-rCL?A$?ź[K!?};'G?y1VzA&@n?U6?dH,?H ,n?r?4 p%{%?T1?3r? Y.g4=ޱ0;N6?:Z#? ߏN6R$?b%\ 6??3Tvr3;Ep??%%<%,?US?BM%vs>xv c C@,ueOn baj?6=li?Ows{gbOsF@Y?ʘEbl_DaF d)W? 2i^? H<$Yyy?tzS?&( NtJk?T?G]UwuO?jCd?miI('Vq7.!2ʈ P?}V LHbme)jZ@U?Hakp?bJAhO>U"\?0Lx@?gW1^]1M]EV?ho\=#L Aܜ=Z?Q&> ,Hx<>?r+BA?$|QKm;C[V?@'?u ?aP 9[@? wY?6OqK<&BOMɷ5?;  S 8>Uб6%?m|3:S:?J&Q?ꤑ5?xtlX5fBqeQ?i{ '0M8ـ^B?9?7oK:vؔ3 'z>tb4G?ѳj10WחDη+?r0?|M(B?۞C Qv5d:O1in$?f̮Ă8?أ7DΪ;(5 8A?spEӺD?vZ*>-G@D." }7?m=?o=@q#!B+QB?E@NB@?>#sDSzG"CvVH?DÎQ?QqT0!T֔lRZ?$P?<3GYϱGb#Z?;A?%1X'FH$#g3FW?N7rvR%yvI?쌂L?G!+@Q C5C>P?i;?mRNf) .SUF?vz&(A9x&-?|1M*?ey!LF?"C)B O@;,,/9?LBA?e@9FJBcB0$Q?R|$B?| {0S+!<,XS?/M3?wB/oRM2sC V]O?81TsFtj/?8ؐJX#:?n9k]vt6?f7IZ?`*?7a8) X  }?]߾]䪲?&h>=_sY'y4:3?/}S?K mU?^?[= pE_!@o%bLE?Ż=?NX?-WbO?}k1ۮ A䵵9?N_}9?>F#~Vv*\XTI|F?XVȐ7? w>b2 BRũ:?)K;&1c>3=(?Y",7ú '?f⟶s4?GkF.m8?{E/;?D7/`5?X8Y$7k+;7?FNKDU2=qgk?>?32 0?N[<`"" I>(,A"LC?$0͂/O?IMkLʂ:TQ;gO?D[5XG? PR=z?tDϰ#W?GD?ܹMJKYd{L;"wW?IA? !@Vb,v6?0nN?W$:FKyզIIJ?3A?yNJ(8[?Qh%b?O:OY?{ȧ#?ǒH2?Oݷ`4Vg?^N=CXJZ'#o7cqI6?+*?)CXa@M@?'RCg#e'tyJ("D4lU3=6?U!/?Ɛ&?KfW73]VK]h0?5y~2?Kj3?sYE>JIт=?ݨG?Q̢Hcv>XB@?~8-eSU(7c8Y?iC'}6?6Zƶ޾JWsƌW?3?&XYcSB??)SΕuI?XD>SG?f8?{᳝_N)V1xP?B v)?(<OlK*g@D?"p?1ED{4B9VP^q`?YG? #F5?(>&5 ?\V/? 6FjE:H? e'US&Cebx*C^f%H?6gaIeh?=Y?GsY?XDkOB T?wW*9=faH(?ߎ2S[p[A??2d?u !W]p(j!a*F^?+Xݦ de[L?^It]?!:aD4@?6S^q?l`W? ahQ:vNb9M}0?{! ^?6'(A?蟁RYy]Xｍ'W?LU?Р^cjw;āf?nLE&8V7z*0?߁rJ?k61vVWQI?K?Y2FS?&ETw$5?lk'X?"4 2EBɪY)-CۧM?#1?QŜ⾖+GZ?Iae  }R@˺/f+$%?gy~|9mM*4~fo/?OvTR?܍7{Ͼ[GPV 9K?T,?4 K?Tv="G,\_0_,E6D?; !?oA'5ʢ~5?v)#_5/\7??s<_ 4]K@Af3?޳FKn3?J-qn&>?Vo$459\2+?5 sL&?[h!8?2&?NS)uA?|dCF>?=bi4? P 54=mFq/nWY@:?'ak.?U1@9n(/'˸6?ph>0?h-o; pH>?;ag q?Bϸe8$^8?8 ?5jM?[G[*?BK?a2W'*ClƩ7?ݟK?P9@Kh!$F?$oG?P^DekxF+qbI?=eĔA?mF^H#ߍ5&oAJ?&? )gP}5'?苊WS?9j= _`&,T;0%YAD?lрVO?M\%k4FNkF g%0F? mB? BDHx1';1M+K?×9+?|UxFR>"j??KVALsk$ڂ!?Iw7K!WM+W/f+4?J4\,?܋A:BɴDS)7?iz.v&0;~&!?X>-B,'?EkAir~jƤpa?̣#8*S? G(-%ahnd$?72a?py$V?lk9W LI?_1a?$"IRP>h`?E\kk?H+X P9?4[35 ?Џ?սbT?K N{.z>? WuO?QqLx_mmB.3 H@?%vC?09:-G28?ގ >9!9P=>s5^;KJDoHهJ?A+wN?BCUN5nSzQs)L?ޣ F?VO2!;c7/fFf9>@?3`,$>uҎ&b.x%?⫚)D?,C,?@|kGo<廆e H?F8G4?Xpcc"QGFv8o>VN?g,?Gug=IH4B}!k#~7 D?/CA? h޳;I#?KRj)?G>2?~d% 82?ǯ>pǚ/avJ0?Efؤ_6I?r}'?>rM7dU2 cX|9?-SxO{ξ1nƎ?3o["?0\ ? A/?uLL{'(5? O!/[feg%y:?lmy@[?A[36?3f%K)kpk"iǢ ??Vˀ >4~?uRD:+ݛay꾴-|9?}n>@0, x ??$(,ڎu!!jZƹhշ;IyDB? W?eA?^ٵYD{չB'F?2^|B?18PbKHN"98jYL?-Y2?XvىJӥ~;LaK?HI.I帬P[:?(\H?l^6C yC!Ej E? n'|6?Iz{G9@E vC?_{w(awG=T#,3?Ob 2?5`;8+@%,8?WPR#?%Rx9lݳ}h2?r 7?KJ !Xþ+n2?.dQ?{j.}V?pNnP4E]?U=0;5U?½oT?ƁJX?}ӊ@uyZ2.wJM?vt"H?.n[yH?+zf3)WuMO?.y,Bd*Xˉ~nd=fS?lm8"?2?ǜ`,1_#L7z}fPlǘT?P5UO?^PQqNt( &?qjL?QNaC?*A?M{P>FS?csևCOMTYMD&dJ%{D?`4R?ikD19&Ou)?(M?a]n;)%Q,xO:0?__*U?s)R'|c6VO5I?If0@3Q?QNԒDL@-xWn9?m&xd??rޝ徾(oDIXrC?ܸ#K:: LM-9?*!:?節H8?_t[mA3ߛA6?4?Byo -\R6r~Yx?PDE?/--,Amw@OJ!rA?#JBJ? 1@8y"& 2J?|X"?bKP2_ܾ201W;ϺJ5?U]?f;: 1S9C5?E = 5? HT$8y+J&[49k?\zZO"?f?5y'1O%Kf8?R?;o }7X2?\܄8?$j (( \b"=Y#O6? ,pA?jh6@vF'FOl_%F?+C?vɲkBJo 7™N1H?-+;%?5J7[JkB3G?W=+ q^_YOSBl+?x8?[ d:\p/o|@?NEY,+{;Z:?/m~6?Q)>n[:Q.sICB?9Y ?j+h? Q+@]?AC@O,\e_`?լY2-P;~H_/pMKYlHk??sJdpkZi$[|U?e;dB?܍q(TguN;Ja?PAa? !9ao%jQ3J^d?2!}"2RE?Y TN?*͈ѣcfWcF?)`[c?@뭹=;|a\Q5yv\X?p"`lZNw=R!ɳ2S?n2Մ@b4ICB DˊG?4Q XD2COGy5NMT9?j'a6?Ơ8?ݺo? v) 7UxFM? ̀9ϐDU6kz9?AgU?%{nU<:䬢FCR?qc>|O:;5bF? ͧ''9R6g-hTYG? ijC?~T(?sp?}T6X>%$=q7?NA$6?Pg[K)2?b<'? v8?68Nu=גre?[D?I6&lD=@rU3?}Ob?砤˜01?ٱX*/?J:YZs'8xu@?~b>?pG7E&L %ٗ;?İi4#,<6?y>_ !ApL>tW@?:X~'r>ȵU7ɖ,:5>)o}g0?)Kt%pp;)k%RM2?9 r1G/,:/,?q&?Hi24Y*S;?zy?}ӹ?tK ?5'ķB?c2Za3+4m@v@? [4;?|$@>gL3 k6? Qgƻ"?Hܶ-rJG>ks1?Q>'IKQ1"01L!v1?ۏ` ?VY9 !N,܌:?n=M+?e>a,6Q?皱bDT$J?'^VA^?7#?6c(X'/}+e?vJU_? } j׀<\?B/c8SMQ>>a?絡W?Yȝ`D hBb??ƫ5R? V6:?@`:L?N,v2Km&W\%J?>>?9h4? ̖[R?^PIW 3WY?C(W5?2등Q=17@?Tʓ+F?5Qdɩ@A?Z'B?cJ@4VM*˵mLS?P?eWnRp5Gd% !DQZIP?yA?cD4L,?j؟k;?]nQC`;Z5? >?!-?IĽ"P$_>elWR24cs3SF:@?-I?15YA!Q,8;?]{6U?q~%.bZ {8t3ܞ\?^Nzn9?HU]:c/?*$5eKUq4wK &?oYeŬ'?q4n5w9?K[b$? ag3.Tqr!?8: *?x%#v<?mbn. ǒV (Z-?%?Qf, nU<Yc>4?'WU3?,AT@"{,{}?ˈ% :?>$,1p6QF9.F?:/?@WZhD<,6olD?Q]ƚY>+$(?_9?%0Q  2d)0#?%1?P<8í#5pA?4?lJdB`f7 ?z``=?o' /$$WP-3Ž`^(?:X(?)1j#(N=)?cM ?'%NF>(T‡۾3EM~=bpdZ?p{)uSM/HD%!I?ƑA?E028B ]cV۬y`?6Ԫc?>g 9n,sRѯAR?((̓c?8XnK`mR^\}"?òlg?(TSLYbx+0J?D2q `:aT?\?Ul \RZ._o4!N3Wcr8Go jUD?*LN OGIŔ])W?}Cb5?(Mna @ w1+uS?|)?;@r?F?dG*;rQC?-*?ì|Tgk7?s0S?#O碷HfKH0?\#??Rik#G-j%iR|H?E-y3$?g2ľu=;7H@:i!:TN?yd2<7?GsT@WbxA %<C?"f,,?/YbIehH' 7?jiJ?92?E'|}/)uX IT9!?tzB9?X10 iP:*,HC?;SƔ?q;z-2C:<.vn0v1/?ާ"? a%?H'?n,47NnG)_0?r*UnP;s!!?*3~E? :߾!D_?D?^?8~gG*"ڜ0uH? I#$'@/?c9?4+?@x :U?'ϢA?+ik8!QmzCW2?SA?P .}1?9{0?*1a+9?=cU)8W+6|=Y+?>Z1?sw&*& W"?N,a?~ IqA'þܯ4?"l~+?k}?T62c4,C} ?( -?ALr)J48|"Xd^)?NOYC ?/gcM3"WZ*sʚ9&?Lv?׽<42p>((7?kc>2f+5)?n5zT*?,xs>'.|yr,?X)?< q"&FHCPvQSJe?L&ha?M]A޺}C?y+[?)~ECj?>EDg )/ޝ,?ݹ)Z[?,Խ&-?F?kl"RgC?QP5Q? 1Zd$Fn%_yfS?O˄8?@mUL YQ? 8h>ukbU[vH?^>QJJn6S?JɎ9:C?P-%;0J? ;B?t UQR<[*?>V?{<'Ud18g??7"S?龛Vv4aN>B"6@$~6?ڽuY<;?62?~A%TKJM?IY}E?-LD KSTu֒B?"q1jBU?km4@fA9e3?*JA2?o3Bw^Y 'gP>7D1?|M:?ҡ7G1yAPnP"?V[=5?BR[ѡ&2l:s?SK60??赉?[':Ɋ:L ?²C??RSi)3@Kp/.>34|3?ѩ*1&3?j܍E Hq>8$<>R9i'>?[A? tl)@v}ZR>X5N6?Y+B낹3?oKJXq6?r_ Rƪ=?aUKd9I;X7>طܣ2?f+~?1?a57-UQϷ)??(*fcN'V\l> =$?I#?'(\= x3LyS1?غ纎,? _}4yG !G=S(?.m\?]Xu.>e/?nŕB6Yb?you?Oĭ!:]%4ć`10?- ?(o-RXyRk?s GW+xx? X?M6tV? 5Skq^>LMeT?SnᾉY0)J?C:J%? =:S?bܿ[D\UB|BM?q{$K?ä[weqb^?0@O?r ?P;RgU?pO?uέ\Tu eK?Y0F?Ded)i1IQ`?/XAJF7o=IyQX?ܑk|"?l!I9>sE9 ?m$`eA%g S#^ZۦP?+BAk:?GGBB59F9ʕ7?'7YL?*4S2EkC"\7?{Y28?{MvNH?%(,L(R-m9|!0 W=6?٬=$G?;|ҸD!}I_= `3?Fˌ%C?r)zw>O*~G.Ǯ#.i7@?2~1?۔='8mjZ2=퉘!?~T&?k! H8q2 7*?X+@&?\MSw1g+z>LjgMX+?S,>(qK^,?t1?mߖA N"UF/;1?G27"?b@LX4wX&0y,A?n> > ‡JFqO"? C:?dtg?O̍ ?80T51o7r&fg1?`Sf4/?q! g4fcHGؾL4k>2)6?A O[1w:b<A?Q ,0=?c8`._:yY%?&4?j&#:c?q,m6㉋?WƆw'?RfTr$Yfݥt& 66B1?2K.?*YR4S 1'N,?|2?tQ7ui:"2?42^&?(Qr+&EhRC =>ul>J($`>yT"?{YX6r.Mf?\J*9-?D~"c[%;4?U?A#4Sev>VN1?Wb' c0QI8{ ?X&z4?e u\|L#k @I6R1Q%?U,,&?(9ܼqd '?Dn*@?|PNH?5?;D?-#?_vI?Z{r~ K52UqϣvPSHiR?f w+m?֦e(RׁZz ʯS?g>pT?u=fObN?xWEAq 6R\ŁWN@? %R?!}`I }Lk?x{n|2?ӴbNHH?d)?+H E Q?_23?LNL!T!)>cvB?T$@EZ"?42?H!XAiS5?nל-?r(2>-*o9[C&GodB?J^FM&Aŋ?@?!@?7lEA~f%O2?j+G?BXx(y` EFvp`=?G?#Bʐ91e6?)7ۙ ‡-\v%1@$RvO?>wQ;0zd&?Ie'?Ẏ ۑQ ,.?s),?)S?{(ֶh S(? iï8TجFu]1?#Rh ?60.CBS`&?AB"t}6?> iWC‡w.6>o(F?livA\&Zava+? 4*?9IN6Qih.@0Ε;? #2?Ao@ԕ#1E)T,=??_8u > M7?WJ[o>>c+R$kMUg'?}JlB?St~(.n&>@${l#?[T#?'kom>*Wi.˧+ RO3?'馸0?QTC;Æ&[8?mQ?ʊBq1Ԍ) ?~Vɠ*g,?1]3g$SVQ?GwR?E0$O?Ly_.&&RZɢK@S?pkb?JN+Ha(m??XK=?~M# wN{_5'kyOv#Ta?tJK8RGROxǍ$fn+P? R-63?.F*?y.{aW?`κ0>f*D0?1 ? 4ts!p4iDy?y!A>'D<$"3?h\F?8wMBK7o)RwgZZM?j/xoE?*wUL숋HaJ?SE?kYQ.[>K!NHǪH? =?=WeGW["K~AF?MkX,?Am\䭍F|?ђG>S=}ɫj!?jm4amq3jX1?1@e!vqe!?xtE?Km+c!{?K?)U.?2_R?E'R?(VZ<+?.C9!?19;3ىD(d3?덤;?SNG3[#K5 3?7\:61?>ï0ϱoS-q%?II?,c v)i$q 2P60?w_)?R92r &*XK!?xo&?@f?-wr1T`M5&01?NX3(0?N5 X3ѻ-.[n+?6?ٍu@}Dz!?5^?]/>6 09 ~J>4b=?j>,X6!%*>_]<0>-S¦>ȗws-ѫ"?-5Z3R?Kln&Q]uHG1?);N ?ˊ,|fQ>$fmVE*t@>2R?mMAI`%?ҙhDy#v[?W8nQ?5,:FrbܟLI(v-ML?g[?˨q1O?LT+[?Fgv`L?Ʈ[qL %^::?K^wR?A+E2 \j5DO R?teN7L4tJ9lGF?= @?9?PGþ*en9TyMC"3=?| jBD?b-ɓߑB68HzJ?}ئCG J2[WzJ> ;a=eӰ1GzHA?:Y?=F5 4?ks=?nvUD ?v[WI'?N0 |ڣ CP!? t-?`.[ ,`UdPC*157??$?,]2 kP҆)+1pElLH?k28?o];>~'{`ϛ9fR{{2?f1.?KtjLP#bl,g(oI>?>hbxb"?*y/?47f.@x_ 1?j=>? # ,mWM3%c?(l5?ABs5A?_(??3B?*c&:f k.?^2-?.%32ߐ"?ft(?W1mzƛO PNH/?Fr ?1"\ bK+p\?%6?^>b6Ć!?n۴U>,)&,r?e*>t9S?x^p/Hù!?.+3?5l `n-33 _3%?z[.-?Q"n/n$>71?HkyR?,#C$+RV7?|n׾2M&?'F -`D&F RQ Q.6dV-%K (%fx/?8*?9u'[IR&oԯ*$?2Pδ/xo !eKw2?|3Hi?yB.[zW0{?@;?e+4_v?O$j8?hT6 k8L8/,>Z` 4""?٠- Ki~(d.?ip)?&,Yq%90?3v+?% oA?R=:1#rV"?\:%?pg&"2?Z% h'-W_?sd#(?'sqY Y7LN?Բ7#y@Ѿ<&w?M [ 3 R>-?)%0V#?prM>DsE:}R ?3J?GG3m=2?X,tF?y2[y,2 <M.h*C(E{$ɻHx9?嶊T :Dx;??IJ|P 4XG=5#F?mg7?aπ3/D9s͖{Y2?J l+gO? c;>H.T$i{Q?3?G(+Js`؀-R>nG1?yy5?"Qz3?ZK1 JW3F?nV7Zd8?qD.?;:2@(iDy$T g6?ìجK].f2?ޝ(8QYPsa^0CI>^=s1?r(?<( *=e&! L.3?ފ ?hMoYu ?o ?u"/l!EY:?,q>Vfuf,M9>?H/?pR˄$4ag&Z"J'?'f &?] +隥$MU?FB ?#O!da4>6TH &?ԗB96"%?) 43>٩^M"+y(UM$?.gI0S?G p M#?`;s"YR=Ùz>{ޓ:U?*ht;?qfaIC _#ǁ[?T)a[?]mXdˉb.)Dw1?-Y 2!^N?[+Oy:?0LJ?U|3B%DS٢!?jF!G?k[GU-뤇P?6_ G? ]cB%E[ 1@SS?@M?Rhr[:o3 W]?ԿH6Ρg_~PF#>,i4?b3 65)&5>[ۂ`* fH0?"._%?<ǏZB?}as&-+6wi3z9(s'?נYj.?9>3~$HE:~6&:?y?LD?p8 C-ǍF?_fF?!Bpu?=P UN?xO"2?8-uG 3GB?38x)n!h<0?,5Mlc>!ZY>J^'{[v 4Lk?? ^@2>/$?C>M%$Wp<~l-$?a!-QZj?*S+z>jྦྷ$D"k?UK? X2@7?V?\& ]>fD)?vk3>fxn+ u?dr-?[hh?kڻ\ej+8?$+?J֖?IO3X?<&,k? )%?w3 R5>NW61 ?\; k= R3?'8??'gm T(?=ڛa?E:J(\g?W<=[%?LV$u$5sh)ʆ*?[-t;(UY?*\k%?O$^I~+}%JG?I?F&q2 x ?7zlx%-%PԗÈ ?Q9:?U2+?=MF^1%M?tE?o N?ߦV R؟6C;+_?!BAZ?3˴-NYX3E=#tI1?FZ@ Y9?$mH KGF."A{z5?؝9?FŚ"D?F1nTiN&$㵷jN?h5\*#R7kʉ0?ԓ??H%UWY$B5OQ?J/>޾L; Dٯy#l#gk?04n-?ƿ?3t0`usK%kCmRLN?7ߟ9?%8tji3UMZ=;N1Wz|{Ed 1PhZﲲ3???G̫4$Cd ( 4?RWL?95/mBҺ>ڄP?X\mL"?\83>Ԑl'ԧ?0{]?1o?''s!,?Jh?{l S+oW ?ZX-?yk: 2m60hd?T˂đ-?B+#:zdS?aef>ϼ?{&>s!*<?{;}8?ІNI"YAJU!&?8*U 3n[T,cʐ.?VZ6㭩$![ŵ'?Kj}5?p k.Rw"+?ܛpe?CƘ%{ /q< ?ة7y#}x {}8?H:Gp 0eE>Z:͈>[Hz?#}%e8H%MU$Lp*LJ?-hwv9?efFlA9?ƱFQ;?{%U?x?*'i+R!dSJAuO- ":rx&T?5~@y%tAoR60Q?ܢu \=)tX+$?R}*?G;5a A?=K!?->p,^)?JY(c:?ȏKvCF?FGE|By[ȫl??.#y1?V[5J྆MdvD?O&FN0N7QT?wW9?h!@8!ie49dg/F?YX:?$LNh+@ IeJ9P?P9?VN]MemSd=o65:B? WK#?xހ0 p'?O0.#?%ݫV[d]%??U?ɠ-Nq,C# <?ssE?/W"?ٱd+?=f(Y%#\ }:?.Rj?+V8G2?gPt 2-"W2w!$.?"Cx>U\$M$b>&?{I' }> '>՟~JVisECLwun&?qJʴ>ؾ$Ez0 ؾ$-? 4:<MXi#I?Z) ?P+-YA@$* ?/; >qr]> 0 ?YK?UM;A /tsX&A?[ T?Bq> 2 P+ YGh l $?DR?>!>~.zm ꭞe?Y@IP0;fV?hm~+YtA&?uZ_?+rپ7 A[̽?m)F5S8DZ3.}P?Q9Q?6D7F;$)߭0?F?Gr>٢*$b:H0Z7F?(,B:MaNLƾ*=?2fA?4ٳ$G;~>#D@ /d_G2jL? 58?Fwz qP["밻Rr9?#<7?&2=)?H,]$*5-8 **?T6(?돢<6햙ol.,?ݦ$?d\D )6A]w2?Y+U3?1< h+`}GN:?Ԏ?"Xd "F&ß?3T?W2?)6Wz uA@шo*?b@kA?]~DM7)w264?O/-?n(GB2$:˯;?_!!?8D" U88|]"4?>3l?&?3(?<?N6?Ò}ұ6/+aBDc?1o")Fj0?&4mIB>G0ےv82g.?&So?UU !4[bk 'Eu?0-i|6%$?znLS*h1}BrW?>?n#?zڰ $?4,$kgUv_?P.-? /(GJ?.k 3?)n+'2/p13?nq:*?:Xz)5r5 ̐S9?yJ{'?9֚!t#FXɌ>>ױh>s1?S?J m6V!?D2#?Hu2JI%&]6]$? 7?Ǜ# >i'8L ><#! G?)d'e(L8q ?5\r)? xhP?mqKVG*ũ+nHk 2鯂U?QVM?G&*&T*y:?E~Dg%?4N(6?)sG[>2 GP?w a _ IE&-oNB?T?T O#+x9-mm>?O+2?Y&hPGA3p[0E?_P?./LloHFM?g,_9?CP>P9qA?kή=ϸVU p1?4sw92lbB1ѥd=?92?Z-?9?<5!'#^5Q)X@?7_A.?2D!L珂h?\P A6U"M%љV?(n~2?`0EC&Cf*8?F7h6?J9+V<@3WmA?MgGd1?`p9Dߪ+}=g@?gpev1?ۊMBiSо9?}9?nb@{X ?k1Ts*?QIr._~'D3e*)buƷ1?OT)4?Ho3! w5$U&^_!?c 0*?53? # &%?RJ~#0?Zzvk1!~?U*?'{-"B'J+6 Fb?D/ښ?1e0< ({?h#pk%?;D+[O`?32"?XuthS %>_ ?e1.E];P %.#?Bn?&\')>vU 2 AC?$2J ?#gg JBԽ ?>V169W حqc!l 8.X#?w$,r1:z2//C?w 4 AgpC?87?h{¥QPd'TNJ?-HDC?-@xz^e A?ùgF\~v^[-R"? .w/?=Nμ2?N@̔ e+ '?! ?<jofV1 UII&ɚn5A?{ /-?7:O+Evf/g4?5.?oU،>ǥ2u[ Q7:?etD[/YX8oV;?D{'?Ll9I,Gc7?{2sO>A ] K4?MKr1;?߬l@?΀%0b%ۖq=?=T?wB08(Czܥ> ?Ks?HD'?-P.юS'q o-z8?g ?-W!/80A ?). 0u-D>!j)]23%?T%#QUN> H>.?o%TBZC!ɸ@? &׹ ?i! ʲ"tyZ<?i ?>h T/u?+V?)8 }S$Ē %*$x>,?-@l!?JLh0(*! 3*2? ?*9(0?/&V*P-*Vm? PV)?^",T:҉T|? V>oQo>!C|>}_#DqFLR ?I ?Q?XT?.>uW >ZsC?OQ?P.x\`-CTW<:4Ha0P!2z-7eh)3Q?ie3?`8LA#63:?w ?۰>?_5?Ѻ+!Z8X.?ǾJ?_mk:>yv$?{㉸X^M?Fb?tD[tKA\ =?NR[=Ro?H[E?@N"?|1?eNAdbJ'4'(? F?h]M 0۹1!&T,#d3MzB?=$ 3:cG;.-,?vCOA?Pf,d?Y&?`Bt91a+o7?XS4:?Mc H?e8t$ !2?NhS>6 4٬*?^1?:Aq%(u +hږV1?E~??vM:;acy{L6?FZPeӔ?Qm)2%.  =Ba?YNI.?P>}`7uy?Gw+e4?xd >1!9rM M0Y*?hԤ b|7&Lt?? g@v?kE?{1B -Nf?2?l-ƙd/>̎=lC1\Z?t@'?޻ A'^'Q(_g"?z)?v" m>xz.g@?lXdi)?ֈ~Jzm0!9m?s0?T8gH7Q)v'M^Ҫ"%?M(f?R~ʪfxiWh?$*>HU:f'?W!^%?7Wa!ѐgW u,3H%Cb:?O7XAc2g/1KK(p2=?" [?#fWRY~u&khD?eSCOdo8JJ5f/ŞǡH{#N1pIL(J ?&~X$Mk,?&3|#`O!hh:?WR- !ډ2E5D9HE? M5w.F#Lz:;?]byؾG !@2 1?3$4+ ?R5pȽ@?J+?Gzש>˥ᨍoEQ>G?aB~, j"F6?+i%?0@, W 3+q?rScV)4?>{ i?؆=5U0_( rZH?{I%E$?D).Gaܖ\?+ǽ32@ 4?jP8?E.9JpmX>V:X[+=?O~޾qE ;eey2T(?V9z 7?c;A-A[H~(mL˪"'?xxV#?6 { Y.üל>9J3?+V?(6cK^ؖ7?n)l34!&?;ܣ.?y¨#)L?ܴ >njA> ?HBCfi?A=?Q[($S[oUM@"?;BξOFvYk>> J| ?DI>0 TIT,_+>`vU$  s~>IE$^_H>u,'M_Eo*Dª?~C!?ioi읋J# |?gWd 4T:>Z>-XV7>QZ>sM7 =5>@ɂ >pI04>f1PP!kgkB?tQGcCaMV!j*E(?f%@vРCUQOE?<%?:l2?.8k%?BNtjþAYE@? FY:(?ڈ51K9duF?&)ι?Ǹ٬H+RY>eݒR?'! !-++I^>7> 6?"]g3-HZ^M)?6g(03CZi@ >?7VC?z-Մ ?'3W>/[E1?Mj&?DE9$B֨p-?]fq5 fho$$a5+?Y_9?zuJAt}2(fF@?+ʎm(?%17bCǦs?ڸvC?U5h)q6c6 DT;?uIw5?{ >7Rgp)Q0?B1?Cp X1_[1R{4?Bq ?MĎ5?裠 &/gT8?:?{̨2#dǪ?'?&6'?]4Ff- -"m?2OhiavP2Eß?r',&"?胡 = l֭xDmGJ$?yJ 4>3yW5!b-teFK?HŝO_&?@ ?UoQ&3W?3?D* Qfi>4A@`?_,a@6% ?$[ >UD">ڷ9cD?+ke?( sN1C^  :>":EK?'Ei?3#Pp,Kkw?EF;B"A.J㺢N?%pOQtT ?=@wW??f4A?{K+:?@?_[aH^>?P69?Q2?~pxe? C/?azXw!{1'EM:?)(3V焓7Er(C?$u%3@?c9)I*&G5C7mͩ:jyd0?L(^ >qT, Z$* ?I}S?lդ/(s^d/;5kYwF10rEG,?D1?ce0UuJ<>l5D?ᾔi@?T4\4bkF됴%?U][?A,B?6!?.?m˒( #vg,>-dPWpMs;>>Y+Ο3>|Gb?±]tuM05HԒԾs7x7?O*Q va8=[Q*?(3?St+q",`Y?}Y~'?$C侰=bފ&!IaڔNns?;R?IOcƝ5D\uF"?o 7QFD?`j̑?0K  X0Z=>#AU"?Kg!HbMP62CZ<1F?ಷ#O?L >&vA>i8gY&?o4"?%;U7*Nxm?&,T`?Jxk}L `0X?>g{ ?! XJhGFSPXkV?o$@94>5&;*2cxWA?)?h*>?m5$?cF0QGH>?:'8tD?,8COG0thP?+.R!?Lʡb!0IX8? D5??T<ӇX=^"ǹn3?չ/.?)*°! ?(k43?-Wu.Q UB? ;ѿZ*?qXe!0>?s&?W_$m%?Y4?Iv H6}AE~>b>N;!6?,`[2oVۼ! ?'H?t>N[j?.~C>^?!N>3˟Sm'PE0p;h2?Z:_#?F/H%B 6^G^].o3,4?_F?CDO$5`;`SG7{|+?7h!t;W!9j9OT?>A?=z/?WT(^<" Se+jz??}kD?\mC?{bE1,9.}> l?Xµ>ܱ[>62R%#p%8 [g!?, D\JSD'!?QLGfWLȞ^qd@WkP?hG8?_\+>$a88E+"?}q>yK%8#b#3uS?`6dD?oPG/?o7k?;s%j??p,~G?85YG?&d:M\m F#6?9xF~ð`,=?T??,V>9=& a)MLY kD?frō%z3|N`ͤ3?E-YR2m"%?p~&?mWDҔ?Mr ײ,?+#׀j.A)kx1nB"fbsA]S2?h;97?CS*@@ިh1?KySF?boP`0j1BKj?Ag`>?Z9,3 S};(?a6?jAK ߤk@@Z x<3?UྚE,2p?M[]"?z| 9 l>@Y)0?꣔ A7y a?[޵ ?A),++ iՋ Y0?r0֨ B)G -H4/ ?\F1?j,&C1V2B3?zp ?!7^hپo!YH {}Ŋh%? eI ?#N2j݇(>^{C'yoi/?ý>BH&:;?'B??w xX>)闀+F!m5F?)N"j]T>C{6mgy9qN>ko>H깾W5u&侰H(*ȾgOÖlǨZ>&\As,ڪ+b`?=C?Qߍ_9V5L'w& ?gI?pG*?+o󾜅X,?4#/8AC*@,8 ?BC?%&$?'*Q>]??5}Xi9C1$IE?s`OZ0$ӑ?E4e+?vҳ'6I>\?؅UH?\~#0^ D(1&?dڥ+?3:{?ؼ@>Z u1+B;4?IoQ ?H5锎񾅍5?_ z)?#$?2 {Jx{OW??)L?>+4f Fҏ?˜>y ?c#?g(wRuz01?\'g&?ن*:8(VN4,?Bc ?\>=&K?w[8\$(1? )3짝?XGw14DT?g徦7 >=d0?>GIU !><,gȾ"0g >ƫ ?;lY>,(ݨvیoD2HaW) ?գhc?Dtc3?@^El&?yt I?^eAָ@ǒbW&I?y=A?>1B?kXM7?WB?-Cd?9 2y,4;?$4֞?DF5- ?ma'?,?OC q'- ,#U4?EAP 3a 4[ T&.?X~$?z%YR +|/ 4%?vDP-?"Gf 0jY?o&7?Tu?V^b /I>=az4rO>T=<%? ?rz5!Șa?ld0e1?+X}@ns"?6wCpNb%C!?-ji&4?=O-$-mw*&5? lG)?`– ?|^(PrRv#15;*?z8 *?\f`a(!jF1W)mVM'?V?aD [T>1ߗ? u&?-YF?ҠZEz.?ל?FA Ԇ9^ ?x5 0 >G1zpӎ?|pnXѭ5?xL ?.돋Bg #!%?\{ ?{ wL%h>cK@w8>Lk?XL_9=p%?}/>QO!o5G+R:X;"]R?;̨_>4dmܼ?YTjJ65%w4?2A5?60t"?ҬT(mY{p%Ri@?K,?sܠW8o\[d#?OjԊK?b!SD-˟&?=Է? Sf.CS/ P4?3o4/F?|Č,p29\`>&L2#i4?{ˉ e'%4.'?珓{O>+[?'y z?m3A?+AA[Z?HHK 3?V"ݨ*xM$->Sࠛ2?t!5#0?2vP,4& e ĩ+/?iFQd#?d_X<ۡW%RˑOF^} ȶ9?VKA,$?y CGd#(D~ dP&?#'e?t 56pﾆœ[չ >u['?Yl(a=(&Y_>%6n?4#ĸ**Wm%ZĀ?8#& ?(!G,?|}> QГ? )G#?>='?Ne%? 'ד]gOF G?(P!"ԩI>@[?ܓY (Ap>yLD?tHtgd$̐b4Eln~֟> ?L>ȩg?.|G%F_#Z ?gQa9a?Q[; ({԰!u+?0Z%Bwt-9?P4 @??:? &?{{ʶ ~^1Ad^R:E?'S?O>6v\HOv00? `_ ~Hd E?YFn@?C*'G EQ*D A??x3j>hn@d{9?ТA?_1FG j16uQG?! "3??!@H f,?.[?RM53qa(?J+?D #\@)Kr$?%v0?I`4ʚ08)_0?~tr"3/wTؾχ0? 0L4b>R$sL!j~sg6C 7/:3?B=?ZM $wr @?>"ZþwI01p& 7%?Rp~_0?G2;/[ உ OXQ>Cj ?!.b ]?\?ꍻR?\9ڄ?d4?'#I  ]1ks?W?~IU ?)˾5[^[>r*6DP?&e\b]R&nD?_?0?&撏 'V*T C ?RAO>R>5J}?Iw?VDb%#e t^ǣ?qGAl땆 ҙB>TvkT\cL s?@;"4 ?؜Nkǝ1d ?y?`Ņ >DS[>r>n!F?.mDֹ>~DӗGW>M*X?pDeB ?M>!+A6?zvt5?Mp 7C!7l<_9hJ$?!͉-??!YuJ6>ADc?SaNGu5g#LhR}2?hv74ɑ>k5?u(f0?n@ $!2# !5?.,?OzP9?Nv0zV>w0wVw!'?W kJ ,J1PY*?%+D' f(%7b~7'“*?e?FEљ4y+ ?p,53)?s= ӿ)+!e܋>h$'S|%0?'+B|1?G [g?{j(@';?̱?2E#ݑ\7[٬t}'s?ts?pxu?m1$a[/kX7L&?Oh ">'!Py>X ?4:>^M90 ?Ʋd Zۑ b{,?N#>1P$}&۾RG(?R۾z.MHLO ?)C ?N9}$>[d߂]F1?H > c_?B>z>{闗>G{7?1xS?`ۺ2?SW?R7w]{mzx%>G拧U;Pˆ['?cUu|&6,g$-s+[)>XJ?: $jYIN,?dGQ?!ؗI=!N0 jtD?{i2g A,7@?$E/?mߏ*+)P59`>?:8?a#d!ԈCم*m`$?zht%?L C:+NgRHUپ8L)|, 4?;1.,پt(0~t'q,21?ɖ'i&9~C$?ڙro6?M% /*D*T@*?#> K5VD>*WfȂaՉ2Nl?H%P]+?VHؾZ`W8V>hE,E3?:ZOYo=( #ˡa*!?D?9!,"pL%_"?UFnS(?;;ɏ" 2eW/hƈZy'0?"f;|!?6;>>Vs= ?ؚ›A?!U v7ѱ ?XT@UKaO iK* Xf?dM ?N褆%ǦY'Ve(??go=>''" ?L>YŧpӋm*Qa;MWm?l@:> p 2\ q=4A?]A}(>a ȿ1DŽ~ ~ ?>`Y5S"? (ו-+"Rj!?#4l'/<0J2>?{8?MS23F?sJ?\qۅ8p,׆2?Uޗ8??. O>.dX$i6?&x[#?4M3A%YmE羍C.0?0BM"?UU77e)2?L(?'\?_q/|O\02?^et#?^{!#ao?I\5\e(IE( 65?͉1?a$M;j^@'l;?/O"?E7*y,jZ!u= -=?YE&?!ϻ?"_ZKK$?77v4>Z='-b{YL2?0`kϾaEiv˾?S8>Ǿ);1Aj==p ~w!Q)?DY ?5@%'(>e?"v,??bQUB&f8"?@ID?A(*")F>3T)?Iwkyjk7*?C$JP?w-:>| LXSѠ>&[?jc9??>_V!v>Ά^?BҬ, o1gvLEQ ?f o=UbjmF? c>wاQ}/|O_Sr> IؾC썥?K{v(s?5B8G{0+M$|oך%?..=6?;(hy?B\$5'45?nFD DϤGT(9f K?880Z e)Ӈ ۽><,?Yh*?k;?1o> 7?ԣsCqS72?lZ2?Cv5Bt|a@2M51?'7'?= @+0N| "Mf=,$?ɛ?nO`+"K;dT.%?CĻ?5-?Σm+(9<?UT`""?$w>$&>~h>!QdDRm无>c=`?}G".~/͟$?D?q% Ծ %?-$?hN-?9;\)?lJ/ZhTM ?_^5H?\7I?/= ZbHY?~>ALGwe? ? I{ˀ$lge?{ؿ,A.t#?vQ>_P(sr ?h*>hlbӾz$?7Fi?}$SB>E#gK(dN V\>0 l?rf{E;6q+1X_j*?ݲ8+} 6H_&|,~"&n0?JEDA?4?pn[:]zR)1k zA?P؜Wf6w[@CU9 .5?1?4F;nf2v#į3]y3?SJ[ ?L!4 OC">Wt6? 3 qO8?3NMD5q̈́LA-Z ?x'?DH+!XEkJD4X-,Z&?i0?FT2;4Iě){Y3?U? j1<7*n?>.P|(1?L.PyŇ */?9_?QmT;g;%Y t?C: ?$E۹>lMFwk$bO ?a( L"ψf?on?\%s<Qĥoɰ1?ts}m!9c)I?4Yw!7AI>H?mi?WwK?t6e?>TdEڻG*>N F07 t,4Ay?{}^hG?L㑂rxLs_M ?h߭?u-ǵ>8RT,1j?_W?x;xKXX"Τ|ݥo(?IN 2?<CJ?tz'?6p!8VFS5<$wn??՘s2rb:q3? i]`R8-H'?To;!?"P5 ?z3%?> fs='_E ԾPc,s z$A ~i%?OCX۫0?a %IjXA?S#? ),?_U=5:6%x? 3T4?LEӭN17m?z0?Gf)?frC DV(%? *#ڰJ ƝgU1j74EHD#?>zT"@< L>$ QM ?ӽOC/?hΎh&v+ҁlC?AY,?(D:ϵUK ?h?[sm $67#?Rh?7%)"W?h)?׿d2.>D^*?Li Fe(? O?h'!eU?Sv?!;?EJClMt??hF?L؁g>_㟰>8Yalxj?dpcf$'ֲT? UtȲ 5KC3NU4`.SYk ?"}?e\ ?SH<5 ?gaky.$? KMu?,ϐ L-?g?a?g']*G\H$?58*H*?>;0H/?ʊ?)p+(xTоݕ,?P_Ztྼ%G]?Vr #sjH?52Nx ?{Q/#U4GudFZA~>/%T n7.%- B?ܹ? W?ubVa`.q6bݾ:1>"U>kѽR은+1&?uUT&˘:WBo[u4?\rc?yL>IfUH&1> @gA?v}!tjj5 ?^6> }?4;e쾤U;xi&wJp 3Sf5o01P5\]_&r""o##`bP>7vje2Paf"0>?u)B,?hl\$?Dh2 !/?:/4?mcA?K8]V]?[$?{=g>&3/ > !e!|%?8_5c :Rk-Ev 뱼+?vZi ?ݧɠ(Qu1 ?ɰ#5?GƾQ>*y/0Mo?(́1?I"oeEo(]5d*+?v ^#?"`󾕮A!JZ|\&?[*>'죇g&Li?K-t ?v#6$ĪuZ X>T_?=C(?6CĹ/ j/,J?ɩ: ?dNf#Ҍs3f#"?7E|{>hm6q< JjVI ޸?EaQ?#tvV 91BX ?Mz ?3e>vX 'Gq*L0? ?V M!G7WdC8XH׾CYC:>ʼnm?%j ?[n$xA6H2?[ήcf ?E &5([ N%P=3% ?qن?eEV/2A!z'^ ?91Z->|' bXCQ?_z>t{~!?Z*?w)>23dl:-??0M7?Ik(ܓz! ?DFK ?<)lZ!Շ=Xh?Z]I62WRNkEj0?`Jwb>XAþw0(.f# "&?uY?p2s"r!a-;%*+y ?d^ɳ?h\'^0_*;4('?ks!?4#Y yy?TR?Ǡ+iӎ Xl y Aln-J?3E˽ !?s&-(% [ ͘? hG$? W>I# M gH? >=@D:t[Tľ*?9[:m뎍 >iHs!bЩG> X?5v ӔݾṼh)>ߥԄT ?TCW?K3?ZB** SᙍAR'BB?l=r%f?u4Mz-?Y)Tc\+f%.j:SB?[c?*C2j#?*$?_,1E+KE?:?&NN(? ɮa1ޥ(!ARB?&w-=%?3vE;%;3?Nx k:پ'ռ5?LC"$rN6:f8>ɪ6?'im+Fif&\g&?d6@d(? q*s D ?4+ $?^(0m]'6u?'vL^Җ?pȁ ~HzY2?9n??y3?oSV>H ?n]&?vLU/!~}>$?* ZK?$؀ /!)#?>&] ?\g,zL!UUYc?ܠΚ>t$݌Dxy>9z>x[ > mk}? g?.461ľR6OB <>kS?w}>X>9y݆389?x+BwnIB,?&?!\Z?Q( J>2eMK"Q><%?G l-?;x -YȒ *?=490?x0UaJ ce<.CJ..?jO/.?E!- >]](d%تkă ?rtT ?7>arjlj ,?~y?za*˟"?dxo/?t>d >{0*0I-a&?ӌژ$#? |E!۰ /侕zx|!?z ? AlX? wH &?^C#3jHH.62?o;┵ ?o,nl ?97?Pyƾ)_GXt ~>94.Ϧ>i*>}3>?;y?kFDӾ}8>^) ?6 )h[1`!/?;Ӡྩs^Z͋,^?wvg?s~^BDWPAP#?I€  $ 6 ?PnDF/  vٚa?"s>UhϪ)O`9?q+00QX%?(ܬK3?H)G6HB(nP\?gp*?Q3.,Q9 Z3#w56?_Z$ SML.AJi?7Q-/'?jiglFeuz U}krf N 0?SIf[ ] "?Tc*.?ȿ(ݬO#$?\v"4rp2>tA?xD$ ?Z }z(xoo ?bx#C&?2eW#X)FJ&?00ĿaMv"C?HuEY>!sʝ {Ԥ?")j!0ș?:"?N#gHUTa!͊,|?k?y/N[sc3>ܼAb#>aDkY.?~HK6?c!w)8t O?ŜA6&?Wܞ{m?_Rc ?H*"QrMl? N>" m1 r</uQ?Y1@>܄4hXS>Qߌ-?bW86]f$?zZ>,+z4C9ı?I??/vm ?]5w ] !E?7_~l1?k N̯W>BC4?аOu!#5u=?S\wvb3?[33^R<,No~2:?D{?^M$}1[otV'f]? A0a?ݓ9x?Ki$h8:Jf hU4?zW$3{<$e-}&1?U60'?a1n&4iv+?}rq?۝T: ?H?!*FA%6?d5)I>8{ %^M}&?䈱? h֫e elE&E>WR ?DRCTn' jA6?w*+?)9>A\{e 5:g!fl1?L4?`jB1Q5 *?P)?BA,?_A?6#>N+>9Fvc#>=S$)ޯ?OAiT >y?Qv0>y$s >09--?g$)`5t&b'>% *?ud0X 킓]I$(Z?m"T!.?Lg_d8h== %,*?r\ P?cyx<6\ ZT<.?K;{a7>Nx.)? .O8>Ը;FD9?J ?wSF>9ЎӚ"nvY?*I ?UK^Cv!?E)?Bԝ<ϨV(n@ qy?(X6>If0 1%e%4>,r(tC?31n?y-֊$쾁7@ [ ?2ԃ^?d-V"DQ?+h&s>``rQz?ZHmѽyf?O,?IWxcǾn R,?H|3m :(@s>+mY>D~;;&aE!>L}7? H; eΎ4"?ʕ!D0?a%$v/3&uN?^ u?/lk?JJ@ ?ė>K?')!n~>^\$?Oj̕$?$ ?I>~44Iϭ ]6>k(? ?:iP>zn{6>'A(K>p&m>k V/PfzMW1Vr|?f!?tR$$s?5>o|%=SY!d?J1>5$1>7< = r? ک>%=>\ jU2 Xv͏ ?= Z?`WI 駜z,g7?jS}5Q̓,#@>H%uL>F?;N:["?U=!ǒ u_>dey>̴$e0+1յ6^fCrMb4?%)4g?yS>bD,v>$'>wC R0eX7c{W?< l?H [?OY{u?ݛtY>Qgþ}}=H[>m>̒AW>d`>GP!?۰K$c4"Y"'?J H?{L~c96?WI ?1͍G>,`zfwHaۦrmJ ?r>ruGa>盧>E= ?gk9{?G~*>S 皴AVt >QAqza ?6=UΐG >zLѕ\?)>e .M&7]95 ?3,#>8>;0?"[>?P_qs !̈́She,?F+6>R{0G$a$~?7x?.fjLY>HZ(`?| @n$GI#ԕrm>xkH!ؾk%jkGFs>1@:.J5(?|^?'`d`'_?2:`356p?}uv?2VD>VR<=Z?R#?Mfٺ>W髖-M^Iv+&R?5WęRv" NEX羬'?P >0d~5d䆔Nn  ?). hi }Yĩ>h )? &ߣr '" ?måʫîkB]y>sy:!' Ū!! L$(¾Ve2 ??)!G揰r>}Ty".?otµJ1m& ?e>+X/?%A*# #Ρ q?g=׋U Dx?%a쾟?gCS/ ?:X܊&濲NT {Q?sl"|3#?e6L|~W[uU}ne%at'?o!⾾T--] ?мe#? U7$?zj?wg%&O_>F.5?jk2g>R9f?fm3>}rşf龡P?Z2?֠$>K|1>3?Pz5,Ҕ?rֳm77VMپ ?ơmi>u_>%ڈ]Ⱦѯbʾ: K?64>C^T>'/$?PJS] yH4*?n H#Zܝھ)R6%ʙ?zIFsvG&h +0?џ?R>_վD0+nZVQJ!?R۞<Ǹ@`)Oմ>YnF ѣ/O3 >u\F%?m3h" %?200?L鎠}?Vm=?l =͖]ﾐR? s?)`)jLf?:Ib ?]%Iw~9d*\ ?8f$>?SO ?U / αfҾ,] ?b?3(:<פ?ҧ t*?zա  D?,x]li># ? >4 2/<>D|xi!j徱딘?ݳ?XB !e $?} &?8+?J(WufYBty||?2  ?w6 rx%'p+?ܟ`6hKM>*%>7 a?rJh^+_8=Țe?տ9-'`?Hdf?e%,HP> A^Y#?EnXmεmaپѦL$?㴹?-?'V ! 1 >;u?o5?S!v ?z+?k7f]͒-A;93%?3H?Tw)̿d?+S|'?CTd8O1"s41>?%>R龞.~绾UNw>c >{~)N>,eV\?sI?rz/gI?b('I`?%k  nSlI?J땤A76J1l ٞ? 9P%}JgGLIྔ fļ>d l"j^/1>yˎ3!?}Dy +>E tLXm?x(?n]]!3 y"!?<0?j3 ')q:D{"?᷆3>^?L1#Og73>r?): ׾Mh#.| Po ~P6t?Ma2? zo^r~&6 we¾f3eqdB>a$B>L쾛I KJ?B??&L?:;WӾnJ?|*gq6KWj%$u\> E ?us0Ⱦ䝑/ ?+CR'TN c)^!?5\=>`\CMdž>XX\m>5dX8 0?W݈4!#%,\O>Ё ? ?v㥕nU4 ?p^i•!?*? u.p4ZO ?.$ş>DwоFQ?-|M>:շ ?„G "D%?2G?~??z ΅t ?8%4eXԣŹ-:ax? *>Hr"E& <`Y ytg)o?ߡyݺ?UU,҂ E * >vw>!(O ->Hbj>!Z?Д?DRxE9>!J?1_&o >'],3?L KRi<??Ю(Q о) ?"r>Nnԓ>/,?ҒS>FCS>w<>j>># o|M._k ?G鄝c>*4Ď*?C"KyN[n?เ) $>Iu>Dd򌬂?}Ln}z?݂?Qλ#?9&r͈1e?Q?_-Gsۯ>>v ?NOV?a@޾[T? C?OB;FV_D}> ;OZ^!P>3ӾiNG7nSn?PP>CKx۾&ϒ%?ȍC !$ )N@*%?`>+}AS?dM?u O~a >%ϯ>.;)woپ-|>tMu>QާhԤ<>aOPP>& Sja&{YāJ?11E S=H)mTt*Q?vHX ƜIo4{rdIk >u? T'V|nXx>l2ʾ7=-?,0A7X> [0>O)Xq9m )T6I?/in0qӾK{,%8}3"C>jo(?GM<\].?3p>)=E2ؾݹH>IG Fr[o?$ ?amWT>@ɾJXְ>OB-XB?(#fgs>l} ?xb ? 2nD.>g?lޤwp,>Sΰ>x >3ops+$H ڶ>0`-J?>f Iy<#>qJ,`W?{%>7(B,m"?X?= 3?,P ?; I(d%<ؾ8->q>Wś a5IfbmjcWEU}6ܰl?N Hga1#VL?0B@ i 2fg?fw>FǴƌ^ģKx[<0?`>0!徣_$/Ȟ?J?t>fϑ\:%&>g. >Lju-5>(FaZ=A`WG⾅N7>R@C?:D>e繸UQ?k3|<_0?bf?GIR0D˝j>xfm ?8IԾ˂->^J>>+Ie ,>o>Sm? չ>+9y&mr>e@`7$>g#ط?0nTF+_Ɏ0?}2 lR<|> &?X [C.0Pp?X?`5 kEvU;>!I?5i 6[ɬP??X׼wa|sn>+X*}>|OT`yڈ pI>ƈW}>H>x-?St]9L?N?=c6Y]X{p>v8F4FI2GG[>kpY>MHݣI>ө޾R>0u>ZquCp3W6?3m5ĩU$vy79nx><_آ)?w0Կ!?etLL ?4?g2G}Qj>Vͅ?pO;oDŽgv>p|?&?U%} 6ngM XL!Z|:>#14$凔>ߦs ?u`?{tZ S?/X>@_N,fG0>MY U8?1h.{?\!9xܗ^?ouƮ >ѤB# SAp?F? E;ַW;>gm?.‡Ģ. ?js~Y e`>ы 7I#?J^iSB".3%VǠtwAӬd ?~_S> AU>Nt>L<~?Ac>*8/r>GtL$p79i ? &E˱>4) >Y̰P>Wse!%V :܃?ЋyS?j OA>h3D?+dU(,>K~ԛ>kZ >|$?WFSu?vC ^(xs>pUԵF?bzY?ߟMVȘ ?!8"?cT1w>5gK;>a5ݾ6a}?ϙ̾NVA>Tt^ >d~?{[gD(@>?1?|:9z><].Z YM9?ki@?ov6ldJw,nd)y1X$s)>m8x,Vm ?pj8Ҏ"&/K> ->k-{%?J`!^/CR'K?.B6?3u!`R>h@nE>) kX[d ??`羃חv2>O?ވǰ?V ,s4?Af?Lע h񾘣Pa>gvo>1\Wْ!?e4? ~FzhO?-Ӂ4$lra ^,]G鄩 z=G_ϝŇ5/?m-?>y? \ܾs%8)>q/9#?,=+%8?}v 4?cw07ȾX0@RO.>+NyvQzdK>$CIo^[2 =fwo>;Vh?mou?Ro .)ĕ%{%>է;*8?QNb m 35>9gޚK?_} c8E?uf;!<U-r?(h*UÂ|[(?譭žQǸCB`U?E >hPh?e(?Jԯjk D| ~Fi<?d|?ߴ.Fo ?O>%[ ?RXw ?^9Jo<|^p~M>4"5<[?'@Gz&!FG`,u ־WX>P>× YG1龨!La?B HY^̋??MoY>`$P@  ?gY2&q~ߓ`Z>qO>vPv]vA0ϗn[)?{⾚US@2 (XC$_?)>`q.즼t)?8l ?cA}5l4?yLŜ ?UPG&D?`~c͌h*iѢ aUL>yv% ?ާRIz>`>/Y(7, ?ƾ??.t@-[ (3Q>z'y> zR`ScEĴ?8E*?z5TrM<3AM"k?N@| S%?Xv$?ǯәf|?' +>o蠟>\ z? )M?0M>>_۪>;F_bT"5??BWW >6ExOW!1ྻ@߾8#k 1N߲?`N%N{j#I_NҨ?4è:߾w:L>u#?t?i [ ?v0AtUDK" ύe ?A;dtOa?Ϝ ?籿 n?d"U?xV[o ggf  ?~MX?k),J'Ø>nt?7L}A۾\N]VT!?yDbL<?}DI0 愁2H38aǟSYy?ڑ|Tt0@w>m9y?ʪ>gIZ  } ?p?s F_?%Y ?<>DUi9۾6_GX?Yo19?P:4>"88 m^>cX;Z?ODxtR>{v q9֞?o f ?nk=xsG~>q* "?ӈv$?NXuoL0>d;0>D-JjӢ#e @d|=LJHm$> a>rN?n/& ? KЫ ?@>? >wۥV>Ng>!,b>)Gv<>W jY?| ?"+VBS1}&>NaDH>=*6 PWw0<<4|#? d73s}o(pkAh/C{~j׾#AI~qW>J5" >7 S??&Ω'^?UI QwCs??&dže?2C  ?֌>yþB5S??#&ƜuUz{?пh?Yv4'k (ɧi?m%/ΰI"?7[r?fOa->k/? , y\ ] +k\BCܾC=10@>Z9Z5Z!?aM0Tmվi<9AҾv> >MѐH,nd*. ?A!7@p /?\?PYJ?e >)" [6&8p{9&(W. ,c>BI6 XeHD$r?P>p>Q> H?ϣ +Zÿ?D+f* ?Oc,O¾>~zQ*&&?" Juį?D=>rR0^px ?Z"2?9?_nSL1T>J;?+)U; g ~geƺSkA>, 4  ?FkLW ?Y޿>Q?x ?2H$h?VoA?r+yvx-?W%4 XpYIxgѵ:Q'?7nG /%axm MO>u/WHؽXY_U:>iI0S$~ ?^.ML>yY\?u>)62cw>s>v5 ?F?򾕛* ?x=c>m=G>Ҡ=^&?[>;t_At= |t?3l\d.4va'H?8?+>5s-?P`z\ð?3I ?:?6 JR?5B>v?2ƕy &>EO;> /ÄվuB8>zs @rA>nj ^#޾wHf,.|] *rߊ?@@l>lh?ou>^ű"辴C}H*[t>ڒZR9œD@+60hL8d2h>inD:=98.D?o f?|/9_o6?&X>囀Ģwv' ?ȕJ>T?p+?#ƥ>0"(_TҾi-O>d S?2B@?W^B>kȌ? yT?V ?"xQZC @8>D?6%Tuw=in!bX2>C~":fȾ쵢%n?8|j3?L 7?oTf:hXc?Ÿ'GMhmVu>MUV>X2L? 5ۛ?M$ؑ>?;`4č?CIw@?'/ǰ?Apr>y' ?oXo eo >]ϕH?Tn0?ՉyS-r>bi؉\}eWq<?傗Osa"L &D 2A ︾OlE`rch?o@ >E*?hr,j>o֡ƹ>f?."ڛ76ނ&_f_>O>Ǟ>徟0մC f\3[-?W>W>8~ ?=v:6C'b]>k^Pxj@iy2ӾJg?Zh&4 ſZxb ?^g7S|A?~8>}#z뾙qmL?Qa]?>7 |dw?]LY?q:Z?c{¾D[TH\? *G>z\؉99_Dl ?} + >h>`Q>E, GҾTz>^LC F@AUC쾮Q?0PE*W?ة|P]H>zu#>k}xm?CSf׾56>V>}|EaU)p Hu>B&M>#dѩR^ _Dc*dԾdr  R-?IZs6&ξQ,YAvGJq $٢?Uu-}|Eܟ> 6>b+ ?GP9>l-h>D+nm? fR&yH>B8 ectrans-1.8.0/tests/test_ectrans4py/data/antwrp1300-s1t@sp2gp.npy0000664000175000017500000005060015174631767024723 0ustar alastairalastairNUMPYv{'descr': 'F#o@RIo@0to@^6wo@cbΉo@uimo@1o@ Efo@6oo@X܊o@^2 o@,Ko@|[o@HtTo@Do@#+o@VxƊo@ޘUo@C"o@\0lo@^Jo@3\o@)=$Lo@L6o@F"o@](o@"o@o@]~o@hzԈo@f6Ɉo@ZRo@N=ںo@^ 6o@0ҿo@Jo@i⺦o@.y!mo@rFo@o@ҷo@'o@']Mňo@~шo@F߈o@&o@<7o@Bo@Ƚu+o@Co@G^o@={o@,6›o@ 񼻉o@w6߉o@v1o@2-o@YWo@5o@;<~o@DDo@/o@33Qo@-+o@o@!ᩋo@}o@o@0moo@~HGo@o@ԋzo@1o@3sىo@o@HDo@ ;-o@6Po@\UHo@(o@fx,܉o@<̉o@bLo@WmVo@o@di0o@uGo@no@.o@\Rn}o@l.Qzo@yo@gzo@#s/}o@GԞo@4{ o@Go@no@5e7o@^ o@$ɉo@ۉo@9 o@o@GN!o@G^.eo@o@5+0o@fȊo@-jo@No@5|0o@ 5o@QVo@"ך|xo@^%oo@l)ŋo@x?o@6ێo@7qBKo@w{o@W@o@o@­ o@-o@^$o@yv.ˌo@q/o@fQno@f3o@}xo@b>o@6G~o@A/ 7Jo@j~o@o@!?$Ћo@ K8o@Lvo@<o@_+~o@g~mo@۴҄^o@sOo@c96Co@7o@ac.o@ZG1&o@ /\ o@x)o@2o@A~o@Io@>f+o@ o@2$o@ ,o@> 7o@r=Co@Qo@ ao@to@(o@7o@jwd~o@xm(ҋo@no@R)o@6'0o@@To@7To@ro@!p۶o@jo@JȌo@Vs[Ԍo@@Yboo@Y9o@GFo@o@S ,o@x{)Eo@Cu^o@[/01{o@qo@RXٺo@5^ލo@o@||X*o@D To@GXo@tjo@Pno@o@nXo@o@~+o@g̎o@?~Xo@:}o@G!wXo@=+o@d*o@\؍o@Zo@ 8to@u@Zo@Ao@ѩ2+o@TkIo@yo@[X6*o@hXo@o@wo@/Po@Oo@;Wo@Uo@`lo@ Mo@(o@0_Mo@U5َo@jo@cMho@/qMo@o4o@J0(o@&Ro@EY\o@W:Ԏo@οo@ [o@QHKӚo@=o@o*izo@Bdlo@>KG`o@6m8Uo@RaqLo@rBEo@=&?o@ ;o@X8o@.8o@FV79o@2to@"?̏o@,o@ ]Vo@۹d@o@=d-D#o@|o@[o@vWԏo@oo@o@-)o@tn{o@H5uho@%Vo@2kFo@7o@%H*o@~o@>lo@y% o@ɽZo@CMH_o@vko@Oo@ONo@+o@>ro@S@o@2'r o@=Zo@BjF"o@a^/o@wo?o@ylQo@8eo@hzo@\+)o@qږEo@ u)ʏo@ s2o@ה o@\j',o@eQo@lyo@vLao@6ѐo@0o@Jo@lo@o@ao@no@eӐo@.xco@;o@Xxo@5"_o@ERo@)%5o@zGސo@EbÐo@QRMo@8:{o@"^wo@jFao@-Lo@.8o@%o@eco@so@Cao@:o@8%ݏo@ jNӏo@fˏo@wďo@o@וRo@o@ o@7yo@Vxo@VYɏo@fJЏo@6Sڏo@ڶo@Wvkro@Xo@̂Yo@k,o@Co@z[o@7~wo@mڃTo@.o@ DԐo@fR#o@n}o@$Go@ Vqo@To@Mo@|_o@GL^o@6.́o@:o@1o@274}o@VKgo@IwNo@@O2o@` o@դ̑o@roo@;o@'xo@0d^o@aCiFo@.o@<}o@ego@#]o@v^ܐo@DU̐o@o@-o@nZmo@Go@Po@o@$r/o@6XL|o@a;yo@EMxo@gQyo@)<+|o@Ro@>77o@{Ğo@3o@o@vVo@K:Ȑo@ ېo@4o@+xo@Q!o@ >o@ZH[o@%)zo@o@!o@n=o@kXo@Ϳ2o@R(Io@1RXo@˲_o@}&`o@[o@To@^Go@uo6o@Y o@mTo@ľo@5;o@,Ko@>Rmsfo@[˷Jo@0/o@`.q&o@bo@Q:o@K Бo@~Lo@io@3o@*Lo@uo@Ugo@Զ[o@#\Qo@e\.Ho@_v@o@WI];o@"t7o@Z4o@1d4o@96o@:o@E?o@Fo@eCOo@-vY[o@'iJio@1yo@ p?$o@1o@?+/o@:lˑo@7 o@Ro@ [d o@;qAo@,Hsdo@.eo@}o@eВo@Ko@M8Io@Do@*bo@o@ro@ͩo@8|o@%=o@?ؒo@j,o@x&qo@Qo@N3o@#o@zo@Qo@vǒo@Ifo@vo@o]o@}bAmo@oZo@ɏTIo@ 9o@r)o@dީo@7P@o@.fo@*do@@o@ԄSo@9#4o@r^o@Z06o@o@mo@p"o@to@< o@/o@`%o@ 5o@LF Ho@ kp\o@$$so@Y` o@돦o@a*Òo@ *Uo@K{o@|(o@X'kOo@+. po@y-o@so@ U괓o@b“o@C=ɓo@Γo@7 LΓo@>ȓo@4!*o@ 'ԩo@e/ao@W.@o@F3t!o@Ro@h@Pro@`ȓo@sdo@{ȑo@xo@ao@:Jo@m4o@I o@@ o@o@@do@@\'fݒo@5Вo@qtŒo@)p0o@٪o@iWo@;<ϧo@$o@V o@)/o@&co@ho@(:o@C뺒o@dmŒo@zҒo@So@Zo@3B=o@~o@{&ff0o@ Io@4aeo@Fo@굢o@5ēo@|.o@ 5 o@G(o@_Do@d.[o@|mo@zo@TQo@o@q댔o@HOo@_#]Xwo@zG/o@ o@o@pe%͔o@ro@hy퐔o@#to@gb=6Yo@>o@.%o@? o@4to@po@Y͓o@R{o@|o@i_뙓o@^43ҋo@PJo@Ӿ[Xto@oAQko@Nvco@G3]o@A Xo@Vo@j,Vo@C/Wo@Zo@t_o@]2fo@Joo@WZN1{o@o@D'8o@.0నo@no@qqғo@o@o@\bo@x>o@˯A_o@!#Do@v>Bo@FƔo@tBo@ko@4ho@D/o@'qAo@'Mo@5nRo@^Po@AVDo@'҆po@'Qٕo@o@ "Ηo@Ɣexo@jYo@9[\;o@ o@o@nb-o@0Дo@ȸo@WFo@qIo@jyo@gaIgo@ }Vo@{;0Fo@18o@W,o@cr"o@8no@{o@@Y o@p))o@ro@o@-o@Ԉ0 o@VʝHo@+Lo@:y#o@Vd`.o@^a!;o@։Ko@#]o@ Cro@5No@1Ko@?}o@9הo@]_ho@:Flo@;o@90_o@o@` o@p}ĕo@Ȁqޕo@ 5o@ o@- o@sso@!(o@tT Ɩo@:o@*^o@Ͽ8_o@jIe>o@UDo@UA+o@вo@Pƕo@]do@;ސo@. xo@>c\`o@-T-.Jo@;H5o@Υ"o@|vo@o@Oo@Bho@y֔o@f̔o@j>Ôo@0eo@ m{o@Qr{o@~ѧo@m岔o@W-o@tHo@!o@QEPȔo@eєo@tJޔo@Po@۸aSo@5o@$o@W\:o@ To@oo@J㢍o@i`o@ҕo@?1o@,P!o@.oHo@mo@FMo@ o@뭉Ŗo@T%֖o@ݖo@6=ؖo@΃o@])djo@-XGo@Ac %o@4yo@=~o@LCÖo@\Фo@)`o@CJko@ۂOo@2d5o@p o@Ҿo@*/o@.ەo@{Ǖo@)o@SS/`o@6,Жo@)o@}o@ܡso@{ko@ޥQeo@`o@ŝ]o@1\\o@ ]o@xA `o@eo@2ko@%mNto@.ҫ~o@)̋o@umuo@bo@9o@{tOԕo@;o@go@&!o@ i@o@eo@ Eo@[o@do@"[o@0P:o@_o@Φ~o@o@}o@xX/o@7M.Uo@P0o@ΒF o@u<'o@Ґ?Ɨo@o@N.Oo@do@UFo@{)o@ o@#vo@yזo@/bo@%Hԧo@l3$o@oư}o@s+jo@Xo@N!Io@!]e:o@kB-o@&7"o@n{o@fFo@Qh o@:cno@H-o@ 5o@o@o@9 o@tӬo@_o@/,)o@h(6o@~Fo@t#Wo@E=4ko@ko@0o@CNT:o@/Жo@o@#o@XTo@o@V+o@kAo@Lo@cft5o@vQo@=ao@ do@no@fpo@xIcMΘo@ o@}so@90#do@ҚBo@Au./"o@>wo@Do@0jƗo@'ko@Lo@=uo@/]o@#IFo@i0o@<*o@ \i[ o@o@go@G,Oږo@<͖o@mILH–o@)Po@nౖo@eo@D/Lo@Wo@W-o@.o@z䫖o@Jno@6fLo@VÖo@?*Aϖo@ެpݖo@:po@#Wo@FLo@hp*o@)шCo@IH9_o@,vӆo@o@ќo@|@L#o@NLZo@,Fo@Q\n*o@e`&o@]e} o@P!o@6'o@s}=ۙo@㴙o@[Ho@Qjo@Eo@"o@Fo@+]ݘo@uo@"o@$o@Đao@ciEo@1*o@o@o@o@ V,̗o@?l%o@)˥o@A摶o@ko@Mhvo@G"jo@$I_o@Wo@fPo@s9nJo@,Fo@eEo@GFo@_Ho@7qLo@uRo@*j3[o@yeo@ro@`Co@+Mo@Aɘo@#εo@Fїo@敎o@lo@G6$Eo@))V~o@HYo@ro@h>`2o@;fko@)Ӝo@glęo@Zޙo@lTo@&xo@j}so@ 4Q`Lo@ݨB&o@^o@oZܙo@`=o@E3[o@Łto@ .p"To@j&4o@6To@;ao@ʏܘo@CH˜o@Eo@1-o@ 21yo@:co@V~lPo@qmH>o@eh)-o@o@oo@B o@,3o@*So@To@ o@ao@o@~Do@Zo@o@}Vo@Kdo@|.o@|o@`P!o@Kv2o@fNFo@MQ%]o@헂buo@o@ܫԘo@mzo@t@Uo@ o@^hwٙo@Wo@*^Oo@E/o@;%o@NWo@:o@sg>o@Ho@no@iǰo@_o@w7o@Ms&o@J/o@o@d.ԛo@P0o@uo@o6so@o~Uo@۵S7o@yo@(o@Ҽo@Dњo@>o@ZgBo@d9o@(o@>6cro@;)do@| Xo@GǛMo@Do@RD>o@ K9o@<5o@4o@e.6o@&a9o@>o@8Eo@ߊNo@I%Yo@0\o@9xo@]o@$Jyʜo@o@$8Ԁo@A=u]o@^;o@7o@3o@E >ݛo@Nho@.o@XĊo@ qo@SYo@4 #Do@"/o@<o@8* o@(o@X]o@Bo@ej ؚo@9Кo@egʚo@ƚo@. šo@Ker[šo@^'%Úo@=Țo@ ʓ̚o@(#՚o@5ޚo@@O*o@ o@ko@+6o@H#3zo@Ov b͛o@Sy*o@5o@Oo@?R*Ko@{A{o@΢o@0Q!o@IH?o@G o@.FÞo@ߕo@"J}jo@*g?o@8CKZo@;To@єo@mco@d_mso@Lo@m8(o@1:[o@)\o@ ro@"ؤo@{_s~o@iv`o@NԔCo@,r7(o@w؋o@UWHo@ԙޛo@^jțo@*Mo@J~o@Ofđo@SPo@?uo@,,`io@)C`o@X4;Xo@^"Ro@_Mo@sLo@9=%Lo@1Oo@uo@m9Go@/ho@gHo@fR^Þo@Do@nno@+Eo@8 ϸo@Q~o@7uϝo@o@ =o@˿bo@NSAo@>ɳO o@ o@[Lo@Pj'Ɯo@}o@8o@ٿ^xo@Pao@Ko@s8o@b%o@DP6o@nYeo@tTdjo@wo@("1o@ݛo@} ؛o@ ԛo@ 0ӛo@?}ԛo@X֛o@rdۛo@6o@^Jo@mo@:]o@䷜2o@Dh{o@ƥDלo@Ml<@o@lo@ݓo@ o@]ho@r]W=o@Vj|o@F2o@@t^Po@9!o@uo@Orşo@)[o@U hko@?o@v-o@qo@MOžo@Zo@gFro@QKo@ͻ &o@#o@*%ߝo@^o@o@, }o@r#M_o@Bo@=k;\'o@- o@eSo@:cޜo@iMɜo@&C(go@Ks!o@lpo@yWo@3[Cyo@kno@Yofo@3_o@nZo@Zv~Wo@Vo@IWo@ڑ[o@p`o@=ho@6kqo@jz~o@o@^o@Ȓ^o@Kb*̝o@ ?o@8Ho@#o@؀o@F<o@)*o@xWPo@|o@Ul6Ϡo@ko@npo@3Bo@ D{o@f|o@y5ro@-1Ґo@Pfo@G} lo@Mo@0I0o@; o@èo@wMo@9Yʞo@oⴞo@@'ܠo@폞o@,So@1qo@G~co@Yo@WPo@VKKo@K_Eo@DDo@`Bo@ƈOEo@hGo@[oNo@Mo@d0ߞo@GbLo@Cy5ɟo@Jo@wO[ʠo@5^o@So@`o@缢o@7o@Lno@4^bo@u/o@ o@ ˢo@x=io@Rؖio@ 9o@@&{ o@$^K:ۡo@Zo@ Gd'o@;ӋSo@)o@fPo@xN֠o@̴o@cZo@2OYao@O=o@xo@o@B؟o@T|o@ҵo@ao@go@Oo@C8o@(_#o@I0o@o@Ro@pFo@;D9 ՞o@!ʞo@a0Þo@)o@o@o@<#o@/ro@m0Ko@m7(o@0o@|cko@XygŸo@%أo@5Oo@xjo@l+Po@Δ7o@1] o@S+ z o@4o@o@h՞o@ TǞo@5 o@Oo@H.o@{qo@Ko@f[o@[Fo@xo@T("o@z{!o@Xqo@P*o@rho@ho@Ao@%bo@R Iޝo@[VL@o@ 2֢o@昺@o@y o@NIo@ b~o@JgW&Ko@njo@Lo@-"o@(o@m_o@PN2o@=*o@۟o@ٱYo@*~o@H_o@}9o@Ȓ_o@vao@3˞o@o@L2䈞o@~8jo@njKo@k0o@Iuo@so@%o@-ϝo@4>o@8o@.do@So@j|o@1po@go@ZK`o@[ͣ[o@&o@s@^o@o@|翜o@Eg~o@LJ ~o@,Geo@ŧgwJo@/o@ "?o@o@qdyo@1s؛o@;0zǛo@o@Ob!o@`o@J5o@X׾5o@yao@$~o@eH"{o@zo@8s{o@Io@ӟo@86o@\૘o@O}o@Zɛo@.o@ >o@/Ҍo@ZV؜o@'o@) o@0o@=o@No@完z9o@@ho@i曘Vo@7o@uVo@xFo@ %﹛o@&Z2o@M-io@l9Co@Qo@|yUo@)Ӛo@ٓo@ho@Y~goo@ϱBPo@b1Id2o@Co@'o@rro@= əo@XKo@1wo@c(o@xo@VL+io@'.Zo@NMo@Bo@}h:o@=42o@M-o@*o@&)o@Gv)o@H?,o@NL1o@A8o@%Ao@L!Mo@X~?K[o@s?ko@"Eo@:o@'&ؙo@?FWo@G ]pWo@_go@}ho@+ WEo@Kpo@Ro@L]<8o@_o@퇽7o@LZ$o@Ko@kޘo@K pܹo@|iFo@pno@ibKo@W(o@.Bo@QEo@7Ɨo@=:~䨗o@ δo@GWpo@EUo@јo@ɩio@h(o@}9o@\+o@ڕo@(~n껕o@8o@$>Cxo@,Vo@F6o@o@#oo@~)۔o@T8o@)[o@0o@C^ro@e 4\o@\LFo@s3o@a9S o@,"o@ o@o@q.o@Mݓo@u`]Փo@hΓo@p"ʓo@f[Ǔo@QL"Ɠo@uėƓo@ɓo@tPΓo@vՓo@2ޓo@*>o@y1o@&o@o@:ã|*o@c@o@M٧VXo@L6so@ ho@hdo@8UTٔo@-To@^o0o@w޴]o@R-%o@ o@\ҕo@Cbo@6bo@Vso@So@۫o@Ûo@_wo@gUXo@TW8o@Ho@g}o@yo@5ʑo@\̢o@0o@ 惑o@Vno@[o@_ZIo@X9o@*o@o@1Mo@ aqo@Zţo@Do@}io@Jo@o@Eho@o@9/o@ Oo@A o@$A o@3b6"o@F0o@toBo@r+Uo@ko@)ɾo@ʜo@Ljo@ؑo@wMo@Ґo@UBo@+Lko@,~o@ko@wܒo@Ho@ӿAo@ik~o@,o@@o@ طo@֒o@zo@I@to@Qo@m45o@ETo@Ko@#o@PҎo@k"jo@Uao@t(ߔo@`5Po@QRro@;do@{'Wo@0Lo@>Bo@Ö9o@ ֥3o@ L.o@fWx,o@*o@W,o@E.o@F>3o@Za9o@?Bo@9tLo@SYo@Kgo@Ixo@ BWo@l˟o@]@o@ihЎo@3#o@{D o@P*o@Z6Lo@=\po@—o@ Ïo@bo@jyŸo@h/o@|4(o@4% o@to@䨷o@ lo@Y"g֋o@( ʋo@.o@7ao@>o@ӧo@;o@o@p@o@=o@&Yo@p宰o@Jmo@o@P1͋o@ܩڋo@Ko@o@)9׎o@ZA%o@=o@DXo@$_to@Вo@}Gôo@['%p׌o@Io@iI$o@VPo@ć/|o@_jo@ڍo@` o@ H0o@ Io@c+TXo@sfo@^_stio@x+o@rWo@o@shNo@1Kso@ ·o@I8bo@Do@bH1o@*o@+8D o@qso@zvo@ݑ؉o@<1ˉo@o@/eo@ o@GJҤo@Y?o@ o@IAto@ Ko@d1o@`Ɵo@mGo@}g9o@ȯo@mo@ωo@Mމo@eo@*\4o@'o@~-1o@LkILo@ho@5̆o@Gj9"o@Mʊo@Lmo@o@aCo@qjno@9 o@B ΋o@۴ho@d{9o@27Rjo@sيo@HTo@zo@%2o@-Fﳌo@^o@Qbo@o@je%o@Eąnъo@g o@ro@Z!'Έo@0o@$'o@-gėo@F5o@dyo@flo@pao@M]rXo@Oo@0BZIo@4YDo@HAo@<3@o@Ij q̅T0??PL|.=D2lb߷>Y >\ZT*jvn4S$? 9b9;G0AxWLMd:':~P0a. C?o}:5 ,ھ4,Q,&cJʾ!U[9UK?=+ml$<2{; aID``/e`ܾs  >C}[d?z^(bHZߡnN#-y?ZRD[?m|jb k?ysv?LRH;{]vEq:tW V Wݾ#Uj?q>;0>o:^2G<_R?"6yryR?B>@gϾ->W>*΁D?8)?R?dNCˢ!?s>ޱ>R+6G[,?S= >5x7?>K ?z)\&?, R4.&?x2u{>]` ?D:">wL,"?ǝ> . ƾӞ>ېI>zl ?u\핅>1M?G4Niα>3< s?w?)ì|?!?}e>AV,>vM_>lp?r ,>.N@оi><1{]‚?ڈpU>lֺ- ? |!> KG.ͦ>x1/=>;%wd?9Pfw`?/\>m^*x>msEĤ>ЁB>֋7>vWQ>s9\>cݐ>N?>F>xm >jĸ>R >Z >0!Ǜ>nx>\bϥ>ZJ=>Zy2>MKnPTX> =3a(>CӢH>i~Ci?=1m>1?j?f ϓh]?S.dZQd? J?4ڵI[wTT\Aevx4K?RݠT>Pt-M4%@$6 V4B-_D?Q> jU5?2J,Cƅ9>xp+z @?F pcF>N"?m,1>3o/>MFâ󾪇 ?t !?@Hel8⾀B½>2 ?:FT7>Ա Ei >iiqIʼn)>cXmLC?P@>>+>~6 p?(?SZnȽ>$+> 0>P.?"Z>j)0> RdQ>7H{N'> >% ?>q히ڴ>mLl>BAx?kX $?=Y}O)k>S ࿤> gj>h2>㱾;>ea&;>_IgP^?E]>>C&+>\9>WZ8>j7`>$6\>c>|ܧb>Rڽ[>N-{F><>j=6Cc>N3I >j(?Lpx>~XM?yd7Q?"˯"PS51R?(Q:ށi_h;?? 9[Hݙ*4pE F?·Eݾj]1T?vK3q;&?<$?8 L'>Ny]$8pj>{XE7'?d)eľn>KKP ? [`!%ǶOgv1?^\>\[pR84bjq?(M?Be0"n% P >F=\^?,Dľv@>ӗ-x> Ŭ+[!J[}e ?b">;\ EZ?tm O?<$Y>yþ>IS>:>`KӾ9rR>(>]6Oվ+#[_h>$q?T1M>LB.@ʢ/u뾂paS>:>EF㤙zܾ$:,O>!>RԾrI>u>oU.E *n\Ðhx.?kF>-vuE>Up>`ZnþI>p] l>*F)վpm>q᱃V>h,]Rی'듎>˝f>ʇq>"(?zmչ@?d"g5I3? !O a~>߱>bl#>1 ?HT`N> U׾a>|!|XRxSڗZ>U>Rm$]AC^OY>5a>4+XC- 1m" 4%|Gc>'C<>dB Ǿ5,Mɰ>dV*m>< |' W3ނ#)>@ |g3xn[E>E>3́#򾚣G> ^AP><;Ӿ-!>D"A>1hjb*ݼ 2ˮp>"H'>&Ic'4뾒 D e >Ըns>N#1|f۾K v/9>(ҾǪy>P1uF>viþB{X?{/,c>NY)qڑE㔜޾ztm޾dï>xt>(f{o0s¾->\漵>ʢgҾ t1>d%>El¾y$YWDR]h>Ռq<>%q>VO{?1 '?ױ@THD>̙%%V#?<=O&$)%߾I|DB ǩ_f@hK\0R.P>2J>(s]ky=>+վ3+Uо9i>P. ` pv~|A<oE>%3d1V\v;lʰm羒`.hN!3wÜ̅FV)߾q)BW>ٙq&q= MeXqcƾ[흩ҝG v?l?U_٪ɃqNs>uÕ!2Gj>/2($' m<7ˣ3> @j>Z^AǀiZ[hl9k>s@>ݪ1ӾkӾCސd>ըAS*>%o_gq>+P¾J냂NzcŜ>C "i/<>w3_>P;&S,AʾѾ/aU>\>} H~" t nIi`Fo>d>yGr>%KiԳn>>G7\>kq >*{ a%f|PG>QFT>`듥|_|>Vebv?|?x{B秶4& ?s 1Ů>_T,9ޔ$1yپ kܾ9/$ |ѩ G >@`jK~>EToifN]jJ>7g>T|/H]1U 8zL)%f 敾`Ѕ4NDByZexU뾓 6뾚C>3G,*R8]i$1#LfV[n l,+>97iɳ>5` +3jھ[7у>+:o>&( Ap;FZѾ?窱>jkYT>[i >,{vc $>VN[hl>'Wa>J3>QcШYİXźʁ>>w>KWn8Cց>ԏ貃l>& >>٢ 0>nWy>Nn>[pM>F>`Ur}>L8Kþ:>]p,m>o6>"" nct>" >lOǟ>`7>Я>ؔ'8>( ҃c>tx!>NC2>̔Q~>eIt vb> yǾK_eV> =[an>S;> Sh>qJK,8?ޒ?O  /p? r/?u= |ͧپȒDQ*ھ6 tûCvu m(>~癉_Fқ>{ 82M־S?>.yYV@(>&1C) i>a^Q΃>xG Aܾ@޾h'Ҿ}XӾ$L>j#rоXĚ>ps¾,<@>s3 >؛L*rD1C۾ Q!$,&'>"Ga>bRY~о1Ӿu">]ɧ=>CS]>Qv¾9 >9eqPg>8DظEn>Ҿ>,6%ľM"[Ծ,N{VV>(pE>Nɾպxcʾv.G>>`^>e,b9(Ð>ǣU~>2QOvBo>D?>I˾\({;Hr΄>hA>Dc8dj¾g> ]>ě>/P vq0f>FR>ͭ 6C˪>E;t>stоI-hʾ)Ir>CKXC>f˻q>DsZs? Lh?9a tf?󫔢pST+nШ?E1]_z\<ξ< f u۾BC>w[d#gHB'*i>s>MnQ$q>jIϾ)/ؾH9>  ƾe5g>!UNѹ]kC5־{1>S9޾/KoG z*Sq!<*>ļ,ܢҾՠ8i>@x>>tjѾOO*>^qh>(Ygwer꾜p^4c>8 4t>CppN >g>j>m%u׾c֢>-?>#ʾt>k>UϣpGn4Oi}D>٘+>޾RPH޾ k>yx&]6E>/wLԵ]ξ63<>Ԋ5>1ȾWx>g>L'K]mpᾮ}VD>Wk`LԾJ8EWԾ^>fC>r#Oζ5ngҒ>w&h>E˾ >sHW>`"60ľt3">X_?b> ܾtF 9(Ȅ??-0:>#M|]y*ѾzVa>3?L>gþxvECݾE>Cbz>ྫ]Y>fv>"Ѿd> _̾0,> !⾈]5xE-d 4׾̯>ɗU(K۾ɷhܾWˆH¾ož\ q2u@sϾWU>vUbѾX$xq2>pmF2ۨȲh>BŔxOx(A 61L|>6p>J #"例Gk1=r:UT㑾8!cW4پe>Wƒ>yeǾRub>V.>}&>߽d XEZzf &֮'>7 m>mHܾjUܾb>F^ >rKn#Iw ξ2^ Qq>n?u>C~=XľxN>5:gЖ>Ꮀ.0uݾM)-K e>UUlƋ/")@K2ѾcѾT:%> M>#Ϳ7>nA*VM?d>߳>f&46ƾz>|o2>e%K盾XN>>,0>NPq徘ԋRh%赾^\>tnOPO>٢VþU>da#ZG>r{>NΊ>#Zr>+{>@vLd>3I}ʾ\VUw >3S02!F>'hbվ X6cj̾TȐ{>WKʾJnξKTx҂^⿾ qΤ>|tb>Kx{|yWоxf>xx5.>Ȑ]F(ℒz` վR#Uv վtb$־T#B̾ m 3:ξ&bRu>JU ˾Kۂ,e>ʢ*`TVƾBhu$bYZ1P>Qm,Ejgp>вuӾWHqǼqF^<Ⱦ2(ʾ,Q8n}틴y:A>hƻ4tӼ?Pxݳ>X3>EJymAIþ&r󮍾!!NM U"Y>^K޷VW>Ty>&]u>H|/z>/p5\=>w6>@.@VSRaL>g*+>Ocza|s>/+t>el+w:ϾYș˾I;$>QYPUL> xݙ>.\>Xd>RyrԲ>e* k>n$q>e'g>jzq;iu1> f[ѺpL+> оQؘ#=W-R>n)dE>E­330>mCڠ>aJ~O>}c>Ɉ>;/>*jϖ 5>MwL#[:;,R+W?ľ'9!s}.>JԊխ@zej¾2Ӻ 軾ћ>CV8Ŕ_Go*p>9sz自^0>,OI>Z9<&dU¾79(eYz>~4͡{h>\"_[&>3Qo>Ց>{n!~rXYk>a~azo7Z1>p>uYi0䷾s- ~><˚>˵vN{k#%yϳǙ>o>Yr>ttۿs}?%]s> à>k>!6>!};8>x IξPP>WkRMWߪUϾV">M!@b<վQJ-J1>\>u2>gi~Ȯn>o>g;BLP>3F5\uG>V(ccܾ.룾V W>"-`%Ǿ[k@#о]>z>:>X:9>cOL<>zE+.D0>1bhE\:ɬ>],C оi |ވit2۟>_ bڦ}lyþ_na(>Q>ǽD>UvF bs>F9>9cCg$¾u>0+x>,VԾ )hC`>dy%k>䳺y@ƾ!btQȾvS>}k*L>R0Uv>I<FkƐ>\|_Z>T>&> 3Ӿq>]F%As>h-Mf%z>5tԠžƾ%B >@b2_>=&K>ZkQp2A`f>۷L>2.->OU>.޹<:W>~j쾁yȧ>X2WygB]/žQ/>h¾<̔!)tjbK>+x)>+ p>t֟cOྜྷ'\>ފK>:Jw0ž-n؋5>'%q¾as>"6r

\Fyj>־͏>ؾ|*>lm> zM>ؿžt>MK=>\7{ܠ¾ՠH)>oFO9)>[#Mپق>?6; uk D>LF˾Q̾*6 >cHGQ>Taq>Rs1]qޗ>F^򬁕}Ͼ1 A>_c>)f5qj3> ;On>r8 AӾU:˫Ӿ#ֲ>DD>J RN>V}s>޷U>sPyɾNfh4>W>#f¹橾V[ld޾6)Mp qɵd>9˶~>F=cѾJttѾ3>,q>t2>#6>ߔ徔?F> x(Q;J;K>ŨSjHAOeIuOൾ#rTg̾]am^ӾC*`r> j٪>zFS!&O m> 8 B舏_>Ĩ߾G YP3 ξALyӾy]'jԾsGiU_nY¾{GI>gpr07>-ZpľCB>цefB~WA>n5׾vSr4?qľ? %kj>+Ǿ/6~ȾCquw/p{B~Bff:;+`P>{'v>HJZ|n?!̾7vK#> ZD*|ֲ>W;ݾxiFy6?vþxt3r>oUо_ ѾD3N )sVr\>2vK+ɷGoS>z\óAu¾>+Zlg6>40s׾_HڛyrbY=BFgʾ>Nʾ o]cMa)S>ct/> 򅌺G>?ƸKоͻ%>=k辴ӡMz쾞a4ʬtWÿ>ҾF^dپL{oI*ѫR>gp'nX+sVAj>  tھJP$,ȏM>`$>p >өLѾo6AoAhҾ}T _4Ftٻ¾ IOǾ'7<Ⱦ$2̈́>{{y>;qp>;~԰ѮlƲ#>; Ɲ!yM1>tJiɾL ɾ!Q>r IgmZEA/ _]>Tَ!>[)7A˴)r>YvC K'nR>?a=F>d;.IXmk˾&a>+wx T2y=PVɊ>E훢Ah JXheķzY>½ʱ>!,eEe(LHd>̗fþ[9>bWoЎ, I>9l>$g^>TmKԟ>vRYG5>WLľ,\C¾nHocc(^ǵ]V>NRʯ>|Dݾ yuྗ-q舠>N5>>d9h>HҾf žKYQ>|>[*LS>^6\o{sx&}ʾ2tk>xD ,qn.Rg}.Z>&Ԕ>g(Al>\0c25)>(d~(;{9o )`l2ouU_ዾb?51ö 0\9>QbE>g^7>\1 r>_bjg쓳>6)"ll)㱌>!;o/鼾\Hゾ?9sշSbuc⡬Q#_8oWS>X^D>֒>䶾Ϙ]縲~S#>Шf> >*.-:os~[ġ> d>{b>Uei|>|S!վ)a.U>E W{ZWvW> #N> JJI%&s㾋)➨>s S>-.ƾ-Rnо-*x^:>K >Sm5>f&{ɡWF>g$1ǴYߋj>{t$HY@FEa腽v)j-ۑ>Ԕ 4/f'| >}'+>ڔ3>e`H>U$u@-pЀ>BA]tp r˴>&h^¾3 3CZo  Q]#6q5Q>r%jW>P$ш>Y'Zܖ>~J` >W!n>͸YY>ߎ@0>U]>]:nƾB|U{H6(H>_`?1Ak峾\R0B>'4Hvqq~>COES>Gj#$>`v?bN`X ƾ {>T٤>V"i@La>dJx>[m>clSӾzBQ׾s++>8b5l>p q"S cժSm>< ~>$8&>OvKMJ>X>'S>z>C mr=F>+& [.R> 3+KDGj M 签ӧ[Z8[l|S |Em>`d 7KDp>jj>~ʅ>a >If $>ȵ>uNڣ\Q>61ƾoMR˞RX},9ms-w[s};5B lRV>WQ>lۿ(>W/u>HOem.> yn4>19ϾMWwoHX⿃B>{@ALŹ`JApLBc>>f6dQ>*h?0u>quJXe>uiQ> >u:_NF(>A|2Ӿ0>/bBD>.E>嫢>PP,r>s% >:Y3@>p*|.&w>?e#'>O>җZ鷾4E>#=>(oN͸>EeqxH V' =~PaMЀV|;>qj>i Zb>BvCl4o>LkA{>M(>V>jw1鸟>?^򵾆!#~>lӥ6g(>D[iXmSƶAe R;VψgDZ+IMl* -oj~]>Kx˖P>؆p>sA:G>1>*͕_o>M`ŒBǾERT'-(f>Yh?bdn.gDZn İfv1>?þ@VYu!r>)xw2 <>0վBz`?!e>:8*>Y>6ԕ >^j_9s>y>(~V|>Yu@>1K_DE<]>:ܡ;-k a>xO1f#pG\>6wst>}p߷>K|6>f씎~>.b&>,Gm>,ĨH)>\4#'ʮ>_.|I?ɳ>cEͲL}l>\AC@ESoM"p>t;/ֆs>BqIVg>lKpįG>ex>9I>- })cidC)R>1"FޱoBհ>,%&W>ďz5Ӵvl[ mei>TK$V>4b%,>z^D y>>}l+1\#ܾQYp}##BWv>75ßH"`<`ǾFhg>H}>s?>1R؅>J#>$P}>O"!Jl>b.Q>R¾MEZN!|ݼ>iPU*%%ϾLxog>Syq>"TN[> xy>!@?y܂>?u߿>-z\;/@l>Mܷ#ϗoA|>/B<ĵIZwŪ}>ؘ0?[Kpxl|B~DSMi>GB]>C6EN>r爖> >B ^->Hu Wz>Q$ǜ>4FV>>Η'>ku*޾\BJq>tL`!lžֲ }>{H|sγqc>C@A,̀4~־%Z*j ھEH>&< >Рe7_>x^p˾Dp(ɟ>9f`>ͣ:Vi>ҖdҤd>_~׸;[9OHk~lҩ>?04DFL P|;þ}m>,1S[> i>zRa g>Z('#>jM֯u?٩>sWL[gXt1>?ON儾f}h>^n5O^+ǚe뗲='/>@Ha>)SAr]>>vCND>D=z.(>iپKt>5j+l>mҹ:H[2l3ʾ;BK~@J־~ پ@{¾ ߯&þvF)Մl̾q>= MH!͍pް|%m>fJ`]oxqGm>Bi̾T 1O)5VD+,'F8¾ws={C+2P>xŮǒ΃S>{gøాNʺ >b >w뾾a DN e=}gL&>C=R0>i.8k⾳̄c>&{kf >^پ_94^n߾7!=x x](ƾn~"־A־h%V>Ê9MC5jS7f оBe\Npu>-fH>H=݇gV῾E0y(RpYQ>0l=^ԭ䅊RYG4 ='o2>gm$>g8 Px+߲qbN>mtQ>[86߾qvݹ>:ӎ+n׾*u>Jg0wN5ᾏKk`v>zV(P>3ӾްUԾ{̗!>7{`>u[;>zqdɾ!(i>F;0PO0Un>2wƌd~vJ\T {uZ>>Ӗ>ectrans-1.8.0/tests/test_ectrans4py/data/lon_number_by_lat.npy0000664000175000017500000000246015174631767025016 0ustar alastairalastairNUMPYv{'descr': 'riUn@@ Xn@H0-Yn@7OeUn@MjOn@ܵCLn@hNn@e_gVn@Daebn@3>>on@v3yn@(Яbxn@;E^mn@j_n@$`;Un@HRn@~MIn@_^+e>n@Fw3n@k)=.n@+\0n@sD6n@ wan@I<-2:n@4|n@֐)%n@x3F}7n@}"VIn@p;{&[n@\pin@-vn@ICn@i&1n@n@40n@9zn@jbn@4>n@R-uvn@Kܘmhn@s[in@=bn@Mu[n@Pn@%Dn@*:n@M]wt:n@lyn@/ =n@Q6n@ HZ(n@SEn@ n@vx_"^m@ym@Qm@n@`̫+n@?!n@[ 03n@4CSEn@p"Un@WMbn@Bln@N tn@#yn@K^}n@;j&in@&~n@Hn@j n@rn@m{n@>1aqn@/mn@"=Okn@own@Gc |n@MWa݀n@l˄n@SAn@&P>n@nlɑn@Zfan@/Hn@W(|n@Brn@U[dn@p}cn@xGAgn@M*nfn@qï ]n@XPn@bAKn@,Rn@ b_n@jn@ kn@v[dn@IYTA\n@T5 Vn@1IUn@tvWn@d/Xn@ tn@%]=n@(aBn@!oOn@0 +Cbn@47wn@@̇n@o`n@in@irCdvn@!F>pn@\tn@=n@մKRn@Dajn@+Z;n@yGۋn@'vn@>Opqn@!{an@VXVn@+!azPn@c2Kn@XtNOGn@UvIn@"Sn@Id'_n@˱'!nn@ n@ E.n@Aёn@=,n@Nn@yn@@Xdn@oV]%{Kn@43n@ntu9x!n@n@ 2 n@Z n@2UIn@ n@Ah"n@Rk-n@=PpCn@WnDn@H]̺nCn@)KBn@Rщ@n@ǺXA/@n@NI%Cn@T̖rKn@ )Yn@ttln@{* n@zn@L3n@e.)n@UPgrn@ten@u7>]n@DaVn@n&EPn@fMn@d%Ln@#Mn@}{N@Un@CK gn@R}n@E-kn@n@n@8&/n@Vx@;n@;֎2n@/)XXtn@;Y1n@*sn@J>Wn@a>n@!W(n@*Łn@h]mn@6yn@L n@nn@."n@wf#n@LϥP 3n@L/0En@c{o6Yn@AJmn@=_~n@6뵎n@L Yn@I~n@bLyQn@Wn@.K9Vn@ȳ(n@v6Мn@5n@Fhn@X`in@2׳Kn@;n@r/ue>n@`nfLn@.9\n@sVen@>gn@(ohn@Эnn@w`<)un@A!vn@5son@瘣3cn@tΙBXn@PfIVn@\n@懢fn@WGon@pltn@x]rn@v$&mn@" Jfn@_n@-Yn@}SmTn@Pn@"4qLn@swuGn@u@n@M9n@t4n@qH3n@m&4n@s8n@@aOn@eFh;n@!;n@}Z@n@OlLn@^n@un@J|7Zn@0B$n@P\n@J݆jn@Ipn@8j=n@jB+n@o+0n@Qn@?xkn@ݳqn@]>˺n@ህ/n@%Dn@n9|n@Cgmjn@*Ƹ_c\n@:Rn@ZF6Jn@MOqFn@r{2Fn@klGn@w&5Hn@'kJn@On@ٹWn@`n@dM_hn@iF nn@btn@nyn@|n@d~n@~TDn@tW5n@&~n@N}n@"Hcn@Ȩn@8Fn@Xn@:in@Ok\n@XwSMn@'yn@yM wn@ dn@A{Bn@ߌ00n@6:g1n@ؽ @n@T-ɹTn@Kcn@|hn@t؍7jn@Xrin@̈Pdn@bXn@yFn@'3n@Y-n@ j:n@nTSn@> Gon@[x8Pn@Q휕n@pn@ܑ~n@tEn@8ޒn@^n@Q}ayn@/站n@En@Nn@J#qxn@R_ gn@+gTn@(Dn@3*/7n@vq-n@yCQٷ(n@z?O!(n@!2,n@@ a$5n@v?n@}In@ lMn@XCLn@7Hn@>Fn@BVLn@b?Yn@dpin@8dxn@~n@)"tvn@gTfn@>`Xn@Ë Tn@HVn@h2RmYn@kZWn@܅Nn@"Bn@VQ7n@R,2n@0j|2n@zD4n@m6n@cA,8n@ǼU7n@ܖ2n@>wz*n@ >U'n@sk,n@9n@,vCMn@en@WHH~n@n@ceNn@ s_]n@7bn@v^n@*Xn@{Mn@ć@n@/#0n@PIn@&1n@"Tqn@Igó.n@:{^Nn@;+ln@1=Zn@=$x0[n@*~n@&Xn@L?n@Zn@hn@C0ԁn@Cn@m;n@Gn@{rn@D[Hn@ҕ n@4rn@aE;pmn@vn@Zn@n(xn@lD en@ Zn@[n@7fn@Vxn@Hm?̍n@2xMn@} ]n@pENVn@Izٰn@ pn@U=Zn@I}%In@VCn@+#@Hn@_Tn@]n@wBZ]n@>C|Sn@8MDn@RD3n@jz"n@NpCn@ ln@ޘ$m@Km@) n@(x&n@EugDn@|;[n@W9jn@Xiun@`C/n@ n@n@ϔn@d̪n@hR6vn@`u#Yn@2Gn@|n@xn@A}n@gqn@I#fIdn@iQWn@Hn@7n@w(n@bn@n@4Qn@ʈNn@Mn@e8.%n@%Gh.n@z9#b7n@6=?VCn@h~Pn@{Zn@ 9[n@S/UUn@c0KJn@g2bCn@a En@EX9Pn@%t[n@+0Han@6 ]n@)SNn@;n@B.n@Zz*n@Y9z-n@| 50n@ҙ-n@V^#n@_@n@+# n@Y̩24n@vkܰn@р>n@"n@Dn@m@WE@m@Kkn@!u8n@A n@Jrn@ Zcjn@|Nn@A n@88 /n@'@n@>Nn@Wn@Ő@s\n@pg`n@-bVfn@(`tqn@A Y)n@ɘn@"n@e#n@@En@n@#Pn@**Ϥzn@0n@G5GMn@ˇY۾n@'x|n@0~n@A/nn@Jow5n@  n@I& n@oRT'n@2n@f)n@?n@D{o};n@6n@E۽n@ѡq0n@_?Kn@Ån@Y?6Bn@݄Vn@In@1Rn@o@E o@Hho@do@XD3 o@C1co@J#o@LRwEn@m n@ ųn@nաn@?0n@a en@ Qn@HTEn@gҵCn@t\Ln@J$-^n@qsn@^2n@lC4n@k|n@tcwn@Wr~gn@902Vn@m ܅Ln@ÑjMn@=?(G3Un@2oYn@“mTn@SiDn@x 7.n@§n@10n@v!m@Gm@yZm@(m@n@[ n@f<ǖ8n@4kuGn@uLNn@ Tn@ET]n@#%\ln@Mn@Dyߨn@qoNn@^$n@3t0rn@_Vn@,jn@5tvn@y..nn@|in@idn@aA^]n@@.Sn@oAFn@=[J9n@Vt.,n@$ n@<n@Ln@ضdn@mKn@cNߤ%n@m-n@7n@%PEn@/<Sn@)(ω[n@ Zn@ >wRn@SI`Jn@KQIn@B On@`kXn@bQV[n@ORn@no?n@F4z*n@s*yn@H£=n@.Wn@!-n@h]BF n@rA"n@[m@g|m@]Cm@哑m@=m@`Wm@9%m@tum@ ڬPm@di6m@٢Fm@S{m@bn@? Ԅn@9N n@pn@p"n@1s-n@(k6n@ʤ:n@95&n@2J(n@fn@Yn@uTn@9qn@ M n@g'+n@gNn@2!n@U/n@35n@+5An@Mx vn@Xmn@sn@}rt^n@n@Gno@~o@Poo@ј)!o@_!ro@B aPAo@%o@Xn@L.0n@G>n@GYn@B:siln@ExLn@$T7n@ v/n@[\$7n@#;gMJn@Zbn@D#un@ kn@)άpn@Tin@M[n@ywpOn@Bo`Ln@pGgPn@w;=Rn@In@%5n@,\n@#}Yn@%dm@1(m@ym@ m@m@0̯;n@ZTXn@TK@,n@0)d2n@/e`1n@.@j1n@{P8n@oKn@PQfn@ f~n@m(xn@VQ7n@rn@/pj|~n@^>>wn@nÐun@&X-wn@Q)Ixn@*йvn@Enqn@ɉ}jn@Ian@&Xn@TOn@&Fn@9n@m!=,n@J"n@Bn@E| n@vW@'n@!1n@ʇP>n@xGAMn@q:NXn@M]n@w[P[n@r#̩Wn@B@Vn@$uYn@b7p]n@4>{d[n@: 5Mn@:F7n@WM n@Ivn@mn@nӉm@1LJŢm@Sm@Bm@̽4O~m@pƣm@6)܃m@Mrm@*A-|m@˵m@p zm@WUm@,,m@N~7$m@]m@'_Nm@n@" n@q'n@Bn@ E%n@Ån@`zC~Cn@˵1Rn@ʇD%n@5d-n@˽d/9n@uzGn@nXJZn@'qn@xBn@-n@PM(n@eFn@sn愹n@s=2n@Gҡvn@n@F*Jn@Yin@+Q1n@@94n@gn@n@܊cn@-bLn@;rn@Ƞn@t3n@3Cn@bˠ>n@DNèn@|eO1n@c{n@Rsn@3Pn@OUn@n@0*ﾕn@ͼ n@ Kݸn@+on@n@j 'Tn@_&n@8n@jYo@Qo@w%n@ǝxn@Vn@]n@Bn@#4hn@%Gn@_@2n@Ӛ,n@t34n@-Fn@)M[n@AmuUn@wnan@^bn@PҞ\n@R!Rn@PǽLn@:Kn@[qYJn@"۲@n@!-n@Pn@RBm@m@u=m@&;m@pTm@jhm@;uQn@n@I#n@ڊ%n@"n@67Khn@ n@{;mn@6T,n@/Fn@hΦM^n@{Zܨon@gmun@ vn@zƩvn@\x0/yn@B:Pc|n@tn@R n@bBg"yn@qn@MOIgn@}\_n@haXn@Un@]N75Tn@)Sn@1aNn@z.Fn@~ԍ7n@k'n@ETn@LY!n@S,R+n@"OJ9n@$rGn@V bTn@w|q]n@5bn@dn@:Ldn@LYen@en@ UCbn@]j[Wn@ɼZDn@.n@(;n@;n@m@Iim@Im@dm@srm@qm@xfm@8VGm@V8m@Tzwm@XQ/Ӽm@ um@֖ôm@A%gm@azm@K um@8Y[m@im@T'n@"n@-I n@1RPn@ m@%X-vm@=n@.wn@Bbn@tڜ-n@bA:n@vGn@VXn@ Won@jkn@tMn@\u5n@n@\Jɢn@D95n@Mq~n@S;ӆn@ZDQn@:0lVyn@vn@csn@OUqn@/XOpn@ ִpn@^un@5"n@,n@n@æ=n@Ihn@kin@Jrn@an@[چdn@ #Ɖvn@c=mn@?in@ᇶ_kn@* {qn@|n@rG|n@v7&n@zn@0n@Ƚn@%MDn@$1[^n@ʹsn@}n@*n@*n@Gޙn@ 7xn@gn@ Rlpn@^Sn@ ~=n@]2+0n@J-n@ 2al4n@ZCn@Sj;n@3=Jn@t츆Tn@ BVn@ATn@2̀Pn@ڗt?Mn@=In@ڌ.>n@,n@Gin@&KRfjn@|Mm@Nm@)^Sm@+5bPn@n@kn@Yn@Zn@ɑnn@đ*$n@n@˧zn@dn@m@ÿިn@evn@v~V+n@%Ɔ?n@x FuNn@10~Zn@en@Xr;ln@[09on@[rqn@"Apn@f[ÅSln@j fn@g_n@YYn@#hUn@c&R$Sn@4Qn@>rQn@1Rn@'Qn@݀Qn@Qn@H7DLn@!qM?n@ љ0n@.'n@)n@c'4n@9:Cn@ODKQn@A\n@ِQ^dn@(in@[&&mn@Ron@6mOTnn@M^jn@`\&adn@NXn@bHn@m6n@HD[%n@ n@fHn@Ub m@C\Gm@h6Aym@Om@Tpm@1n@!gn@m@6s,@`m@nm@ϱm@kQn@/9+7n@M#n@=Y/n@JNj9n@hAn@/:Ln@z^n@ rDun@n@ n@ţ0n@fn@Bsv,zn@mn@J^`n@lvibVn@|P4On@pJn@PJn@15Ln@PMːOn@ҽ]Un@kď^n@14ln@t~n@]"n@u0n@E'"n@,Mn@оn@ O᷽n@~ʯn@kn@hn@%Տn@A.n@Nnn@䶉n@n@*n@n@Wn@an@Yn@Eh8n@j n@QqC_n@~Cn@_n@wn@Kn@ҠE^n@fn@0n@G_n@^C}n@rgn@ݟbPtRn@Jn>n@^H.n@; $n@+* q$n@zH,-n@$n@" R1n@|`T?n@ 60In@tt#5Pn@Sn@Pn@In@u<;n@L}%n@r n@rܖm@,L85m@9m@# t n@\<n@dd%n@ F' !n@qV~n@-n@Yq n@z%n@mQn@YLV n@:m@@X'Gm@ТRgm@>Dm@ n@\}_n@W+n@4y=n@ Kn@6KPn@&2Pn@*+On@V(?}On@IRSn@h=XYn@Aem^]n@7[N_n@Cª_n@Ԝ]]n@$Z.]n@Vg^n@L_n@]<~^n@^%^n@1|`n@Ǥe bn@DZ\n@/yOn@}up@n@)qC:n@m?n@x{3Jn@%Xn@mdn@BcX^nn@ޙ un@IUyn@/;zn@vn@_Ӛpn@@l⾗gn@hZn@oKn@j{}8n@)xo87n@:S8n@R1=n@pCn@L33Mn@@߱_Zn@#skn@6*)n@٠n@ ף7n@jn@qpn@On@c 'o@'i4o@~Lo@A\kwo@40n@E+n@/3^n@i3hn@&n@bun@}un@2}zn@P Ȑn@R2n@9={n@%vn@?$vn@;9~n@Vފn@VAjwn@b)un@dn@kH "n@ n@n@> n@X?vn@ЧHgn@@9oUn@]ܾhAn@P/n@p&TZ n@ en@Ư IQn@n@ gn@)@&n@ab4n@ ]An@fMIn@]WNn@ZlLn@^En@5z'9n@k࡮'n@n@n@n@IŐ n@,An@?A)n@W$K3n@4n@4RӲX+n@dn@"?6n@)n@ g$n@҇b"n@.:n@0m@Lwcm@ ]4|Vm@`5m@a4mm@5Fqm@"m@Im@YI n@a@n@ jc$n@:'n@,ad(n@8{,n@r7n@^3 `In@▫[n@Dhn@+`nn@C\mn@w+gn@ói`n@-|n\n@Zn@!Zn@&[n@U]n@,|5l[`n@~3ˎfn@P}#,on@gxn@ԑDyn@ Hȷpn@k6 Zen@nuL_n@&ê_n@[JT1dn@e2kn@7ԧs un@&d~n@֚؆n@)6ߋn@n@Ȭwm@=tm@hġm@ Kћ]m@kAmm@qLm@$Nm@oRm@9v m@m@3u0m@NC8jm@m@"bm@m@*rͨm@2Wm@'m@vӿm@^Vym@7gm@j$m@ڦrm@ 3%n@_,n@vuxn@Mlw"n@to(#n@[!n@pn@Jձ6n@nuyn@Txn@+(n@K">n@_f#n@^/n@S=n@DGn@4In@(]Cn@Z\3;n@GZ4n@ S]0n@VL/n@oV0n@6s!Y3n@g9n@Ky@n@#~bGn@18TNn@׬Vn@oozZjHn@~>n@'=n@S-^n@)n@ˢ(,n@itn@ nn@DJsn@a|eyn@Mn@*tjRn@Ozօn@( on@A^Jn@cB~n@MԳH{n@X wn@Yusn@ln@:%bn@eSn@rAn@VP/n@f`fn@n@tn@U:awn@ n@)n@ $n@w=3n@bwtچ=n@^yvAn@h)GAn@9i%uQ_yn@͇Lgn@ZTWn@48Ln@M 2En@ J@n@!8n@td'n@o΋n@m@m@5|!hm@ &m@om@ecn@Gbn@N|dn@_in@G)on@tgqn@H߿nn@Men@]uBSn@A'm@Dgm@Jxmm@cm@!uqm@}`m@T~`m@tC+N7m@%Ln@1n@V@y1n@%Fn@~Yn@5iMgn@Y{on@Sm1sn@ Qctn@]tn@jPMbwrn@vnn@R:jn@fn@*Lcn@Mnan@#tPbn@܄pin@׬|n@b:n@P͐n@n@tFn@ofh§n@ n@zn@b n@AE@n@g:#n@8nn@In@bn@2zD_ίn@Lphn@hZGn@hBmn@\n@L"Tn@z9Un@!Wn@4Sn@HDn@(q)n@en@.>m@\Om@(ߜm@UbJgSm@m@|m@hG厷m@:m@ `nm@7.-m@bm@XKήm@ -ym@am@ι-m@x3zm@bm@2Ym@ғjzm@'՜Im@ɶ=n@V#n@?/7n@(n@=n@{$—5n@\i'n@K Bn@ Wn@Yn@  n@Q@n@*>m@ϬUm@ %{m@ }0#m@Mm@o#jm@q4m@n;asVm@[Jm@>Vn@s/n@z풙n@~F$n@ybn"0n@*Ȍ>n@oIqLn@LTn@pYn@.,^n@Pb fn@!rn@N߃n@o fn@|@Kn@䳮n@VEn@+#un@B|o@sX1o@9 4o@ o@ƭ4o@%ǚo@/ =n@`Gn@W6in@]n@O9n@?J:n@nrpn@n@?>ٽn@j7n@G5n@6JYʊn@T<}n@x,Grn@ ʷjn@Чfn@اdn@ 1bn@d[n@a^qRn@|yVHn@?An@~+@n@.2Fn@wnQn@sP_n@JHlln@ rn@ln@ڶMon@0M{n@/<n@,1n@RCn@jT+n@1n@nn@Y^n@`a7n@n@xy0n@'n@r!n@1y n@,Hsn@{m@ m@Ԧm@Q^m@(m@5lm@^{Նm@F m@!|lm@rm@_m@qn@{n@[On@~T/Pd$n@Ӈc2n@h؇@n@/rJn@u*Nn@!}W_Rn@Wn@,it`n@=Hmn@LX83>}n@dV] n@ɩmn@4ȴn@W[n@~n@ȩn@[n@\ n@n@tLn@C n@bMn@䗱n@" n@Ħxn@Z?\n@ީ|n@.}n@PCn@n@RkC&n@aV޸n@@|-{n@~_=n@ǻەn@ݎ̊n@+in@R'@zn@rn@kn@`Ho\an@,Un@ieEn@vld6n@%_$+n@&n@R6)n@,3n@ l7Bn@(m~HSn@%'4cn@|G$jn@ND"gn@ܦI"Wn@O>n@||~"n@5kn@)Нm@Nm@5Mm@'_m@m@6 n@An@Ro.n@R;n@{a)Cn@]V$sGn@mo8Fn@*ӹLCn@5y?n@~0=n@?n@ An@s4!An@s9n@aSs.n@h#n@M n@=胥n@J$n@"k n@8Awn@1܅m@yKm@_` m@MUzkm@ſm@Mm@gm@:^$8m@m@/m@ ,?m@x4dm@]ӗm@rm@b0Zm@3[Em@u3m@~m@n@!B(n@J]Gn@han@Mwοpun@ ~n@&(En@;,#n@m>n@kn@!n@|tdvn@zX_n@WSk"n@ yen@S.xn@&]Bqn@Drn@s}n@SO!g$n@JEn@0Dzn@;n@ %n@2*ۡn@Hn@Ɂ]n@ Qvn@Rn@(`n@n@/q0n@]^ n@pJn@&އn@,pn@/cn@ cn@kn@tn@i:ktn@-hn@)BQn@ÑOz5n@M:dn@%<n@E%m@VQm@mnm@;Vm@ 5m@ m@) Xϝm@CB_m@sbm@J|m@lc,m@~9/)Am@+,-m@^Bm@fm@yr.Zm@9$m@bm@SLկm@Tr V n@\'n@En@W~ʵ_n@7nn@C@0Hmn@!:^n@ZKn@OL=n@w"o0n@)$ޡyn@:T41n@ L]m@cdem@#m@Bm@xv-m@g$m@Wm@٤0m@Z5m@m@J%"n@-bO n@~%n@'en@fq&n@$ /=5n@$PP9An@iyGn@LIuHn@DIn@:aDKn@["en@6un@ n@dn@‰n@!t#n@ n@{:n@,Rn@EoOn@gQ0n@guE&n@ݵn@,{n@E(n@ xn@ߩn@!bn@O1n@oKn@t#v]n@d*ƭn@C1n@cn@gn@8 n@[Ì?n@ܐn@an@˴҂n@> yn@C(ln@qTh[n@Hn@<-l6n@L'S'n@0n@[[)Dn@@ZY$n@31n@|{Bn@Qn@%[n@;JnZn@4dwMn@1ʑ7n@լȸ.n@!iyn@m@a7m@I0%Am@Qm@Um@ո.En@(>n@[:n@\/9n@Tui8n@ӂ4n@(I+n@n"n@;?n@|^n@Va#n@tP#n@0n@(eyn@חEn@91Em@v#7Pm@&wm@?x5,m@dxSWm@٭g/m@Pm@}rm@Z.,m@m@ߞxm@Olm@3im@2^bom@{m@X罖m@$!߲m@wwm@-*&m@-Y>P!n@En@5sbn@@xn@|…n@rY{n@ޖn@h`$n@J?\:n@MTn@J<_n@n@$Kn@n@9n@vmn@^>7tn@y|/mn@,fqSrn@ij:n@T.Ȱn@sNn@knn@1@pzn@-A&n@8n@TEn@1@(n@cen@kLn@Xn@@XSn@cG1fn@[k4Kn@RTԊn@"un@"hn@ ^cn@9P4fn@Fd#ln@tFnn@ +hn@TYn@s Gn@!l5n@^1x %n@ln@*fm@Y4+$m@-+m@\ЎGm@Qլm@#9m@D'5;m@_?_m@&m@}om@xۇm@{)m@I>m@_( vm@3m@Tm@m@@lbgm@Km@AQ n@r%$n@0@n@_n@&͋}zn@hR'n@Zr8므n@奿ln@>3Vn@kGeEn@I4n@En@lHd$n@am@~Ym@3]Xm@ĉ^m@Cʘm@Wm@Hqm@-z5m@g^.n@v-n@kg=n@o,!n@+Bt&n@XR+n@' 4n@azK>n@. Fn@@%ϽHn@X\ $En@x-ƽ>n@q72yw8n@H~3n@lu$2n@n)6n@Y&;@n@NPn@t1cn@Jun@j[uln@nzhn@bn@<n@&n@xn@o@,o@ ?n@0n@ n@wn@ vz+n@|n@Dezn@.)vn@<ٹkn@F @9\n@] Jn@?qNr8n@Ѫ*n@:a#n@"n@ ǐx(n@l&3n@B@CAn@D/Ln@*zukRn@e+'Qn@%Fn@sX4n@e(n@W: n@_]LHm@bcDLm@m@cm@ Om@{.m@ <n@S ,n@{ XBn@󶁐DPn@NUn@ԯARn@:4'Kn@;.@n@|G7n@Bk{1n@CG.n@>k?n-n@b)n@nx!n@n@}n@;#n@(QJ-n@'2kM/n@RV(n@ An@ n@Hn@aɗm@C-_am@{q[m@efm@E4WIm@̑om@2m@Sgqm@:[m@#OLm@Fm@uu@Km@׸Wm@/Nim@<(~m@Erm@ FQtm@E:m@M n@~6B.n@QJMn@Jӽfn@\)Yzn@ F2!n@>`n@dn@wn@+ mn@@ޥn@&ªN=n@Ѥn@s`n@Wn@ Jn@Z)%|n@(Xhon@H%&Ukn@5b'|n@F)n@zan@ɿ|nn@/؇,n@9Kn@<n@?GKn@n׋n@;}Yn@mn@N,n@!ֺSvn@Kn@psɔn@Źn@Apn@_dn@1{_n@jbn@Omen@smc0dn@tT_n@ Un@>TΏIn@J Im@ m@Cqn@&n@0?n@X]n@ZѦxn@Õ~qn@r|n@p-Q lgn@ȵRn@Cn@k5n@ߗ^&$n@ź8n@9<n@/n@R( n@ n@) n@n@ n@Gl >n@ P9(n@|7n@_iAn@KmFn@մOGn@gJn@6rNn@R(&Qn@ WNOn@&En@W8n@R +n@fn@Xn@hbY'n@5jn@*-n@+ Dn@c/ ^n@&L oyn@:㘕n@kw n@_un@\Tn@xo@?@Ko@Do@RRJo@{3 o@.Yo@s@dn@;ٸn@MY%ќn@|Dn@Tq#n@UaLn@#*n@a&@8n@ {n@un@ʧkn@hbn@YmZn@2Tn@+Rn@SWn@sV8`n@+Whhn@_Kln@Vhn@{Z_n@ɑ/aSn@v)Gn@3C;n@]g3n@N0n@$oS>3n@N:n@]_En@xXQn@ݱXn@{Xn@SEm3On@GAn@wі/n@Dn@J@ n@,dn@?n@_ n@n@u n@ȃVn@=; K,n@`W?n@m1Mn@^%K7kSn@ Qn@MJn@d\?n@S2yU4n@B=M+n@)~&n@lD%n@O$n@)h!n@ĨAn@>8n@ab;"n@zɩzn@P%n@^.n@瞷s:0n@r=*n@'?#!n@8n@<6C n@Tym@Bm@2BPm@wm@!*m@S?*mm@4lμ&zm@ ]m@_ Gm@(<8m@aZb3m@; m@(-m@UU'm@Ojm@$sm@ʌ$Ym@Dm@[}m@ľ5m@;Cn@Zn@,un@9z0n@TIn@ufan@%qn@tKqn@kdn@AQSn@TFn@I[{i\=n@G3n@MQ*n@}/%n@=&n@ٚ/n@Km7n@c/p9n@R67n@ D6n@^:n@);>dAn@(3In@K Sn@SӶYn@^n@bn@|UH$~n@Fdtn@QZjn@ u,_n@'JQn@.:An@2b2n@#(n@_v%n@v)n@EՇ4n@HCn@s_On@!lz3Vn@-5 Yn@6Xn@zHvUn@15Pn@r)(qKn@]EEn@VDn@=~n@1Fע&'n@^3k)n@@]Y&n@Y3A!n@(QreBn@ jX n@!hm@L3m@1Qm@:+Em@cޫtm@IE5m@ɥejfm@VhIm@b\6m@7.m@R1m@x}yZn@fn@<^Qn@#߮n@ HYn@$?n@QOn@J"[n@ (`n@?in@siGn@!l n@n@B'On@7n@wYn@SǕ{n@7g=Nn@M2_n@4jf6kn@don@hon@Ŕon@1?7on@m4nn@ #ln@iu>hn@0/abn@_'Zn@.Un@p =Wn@g_n@ 8Q jn@@nQEqn@4FPrn@fCW+#mn@Ei*dn@IkZn@NU Qn@XЊHn@>wkCn@@3Dn@Nn@0]n@lSpn@%y{n@/,An@In@NCn@n@rg˺n@Ln@-n@3ڏn@*#n@@4|n@n@a#Kn@e.]*Tn@JVn@;TQn@:Dn@q,v1n@ \n@|kvn@`yn@=un@?P< n@Ypn@SiS n@Յn@~ n@Rʘn@&,n@Z n@Ǧ?7#n@̕"n@n@βOAn@WG n@alm@C85m@AVm@?߻m@XXAm@vlf.m@Ȁem@FKm@ w;m@R`6m@;":m@ Bm@&Jm@>%Pm@Tz4YqVm@ܺfq^m@ljm@vWy|m@Â_ۓm@ӷm@T 5m@Hk om@S~.6n@7n@)UOn@fn@#~n@n@0rn@Sʏn@ ׃n@|;n@Fn@7gn@ݿ³n@9hn@gSn@n@͋NYn@W:Vn@"'n@gYn@#n@,8n@DNn@S j-n@mn@s4n@M {Pn@6<şn@W\PѶn@V_4n@n@)^gn@nn@zn@szn@}bn@GRn@ YEgrn@*8gkn@1-_Qn@}M#n@m@U"$bm@Nltm@AFym@48oxm@m΄m@ucm@lξum@m@IPm@~Iam@T;m@Hmm@sPm@n@n@ Lfn@>B7'n@Jp4n@#cACn@F%vOn@?JBDXn@uZn@}5Xn@WS^zSn@l)}Pn@¨xRn@)v\n@?ȿkn@sCxn@ʠ㋀n@m3tYn@~C}n@k(vn@r)]ln@;C`n@N.Vn@^9bnRn@v]In@HC @n@)Ls8n@9!S4n@h4n@gΤc:n@-5Cn@y:Nn@ ­Vn@? oo[n@Yn@l%kOn@v=n@@-(n@n n@!en@:!n@(K:n@%Okn@i< n@w?z/n@>Avn@l7n@0,n@Z8Yn@n@{!n@£<#n@N #n@>n@(6n@ɱQMn@&un@6Q6%n@s^n@[/n@zm@`m@:5m@`m@,~?m@X}うm@XNm@׍m@c\m@ m@}8m@JYm@ZPm@ im@ؔzSm@8Y1m@M{m@sǔ=m@X z8m@ʹ,n@6.2n@:$n@h*?n@dkGYn@`gmn@vn@%0wn@FΏrn@/ &vln@;fn@gFdn@.Py{^jn@ұ0e{n@P;Քn@m=n@2n@XPn@ en@=Rn@MIgn@+nn@="n@O'ޝn@xn@9Dzn@܉mn@ xqYin@Lf݃~on@1aVn@cXn@hwn@1itn@u #n@IѢSn@{x͝n@Z]!rn@ n@i, n@n@V-nin@Zn@TiVn@iy^n@ST)nn@~)4@n@!ByU$n@n@\5ּn@6u{jn@@n@(sn@ n@2o@4wo@>pYKo@ ^A"o@'o@dJ&o@E}o o@d8o@K1z o@1ZLn@On@-2n@=8~n@n@9n@kǽn@uC=n@PDݟn@V6n@~?jn@wn@!nn@7Nfn@sȻ^n@N^Un@,^2In@ w;n@27/n@ o&n@I,C"n@ClK&n@( =1n@0K >n@?^}In@~#lRn@l즀Yn@hg^1]n@waS^n@"]n@U]n@zJ bn@~qjn@FEun@ZAn@@an@* n@iR#(ۇn@Dσn@ e}n@g{sn@ j hn@h\n@@ ]n@55CK,Tn@tKn@PEn@VkAn@Bn@+HEn@* AKn@Sn@Q덊\n@ Lbn@܏Afcn@.'Zn@gnGn@xj0n@ n@ n@W n@}b n@ۙn@[n@(\Um@H> m@㬻Ln@6o`n@).n@<@"n@h/$n@I %n@axm@ {m@m@&m@fz3ǝm@>QTm@m@lUllm@HvŲm@M!m@,vCm@Rm@{T;2m@^^m@5Mm@OZm@IyLv!m@tc|m@m@3:n@3&!n@,Vh/?n@a-a]n@F:sn@R}n@1+Dn@HoTn@f/n@Ò픂n@=cn@Pgn@P-B]n@Ve n@3+ n@dUq^n@(jn@@7n@Z`in@n@*]n@ Kn@5 n@,hÝn@ߩn@-]n@vin@ >:n@Kin@S_bn@˕{Qn@hm8cn@xWn@+n@t n@p1^ n@yMn@,תּn@fgan@=5Hn@::n@G9n@8[4An@z\Pn@ݥQHcn@O[|Gwn@@En@ھ(n@<Fn@hn@pn@ zn@=umn@= D& o@HNo@8L +o@62o@i{1o@\*o@T3o@@FTo@ͺemo@Cbn@WRn@:*#n@n@G/n@n@5vܵn@@Ȥn@;n@Zlbn@Xn@S?~n@;m}n@ ˫Kzn@t\Zrn@:t'fn@ݜGlWn@SZFn@VL8n@bq /n@;mZ-n@~o31n@ r:n@3IZCn@2Nn@3xWn@3X_n@ZWen@Xkn@on@36un@6u{n@y9n@n@L@n@nn@.n@Y`n@Yn@1/n@m1tn@ce|hn@Cvn@̰mn@-Gen@݂_n@"4*)[n@]S7Zn@W@X!\n@WL_n@I`dn@'Rjn@cpn@2-_hrn@Cin@tSn@oT8n@{2E~ n@ n@/L# n@ˈܶn@m@Xm@nm@{Ҁm@IJn@hXBn@n@>!n@4"n@Tn@Yޞn@BaIN n@&yym@ +2m@Sͤ m@Z;m@O6m@HSˮ-m@y1m@dcm@U0({nm@&5Ƅm@P%;}m@>tm@Ahm@D8Wm@YAm@Ɇ0m@jc)m@p,m@PX;m@^fUm@+J9xm@v#Sm@yhm@Xm@G)m@|@m@y n@I2a n@LXn@&Kn@,ֻ~!n@ںSr6n@zOn@4 Qhn@$T9|n@9drn@8n@$a n@fP,tn@Ep]fn@-(fn@$`pn@tR9 }n@@An@vnn@7eBn@1{ALn@yd>n@CI n@b턪>o@*8o@wJ2o@3 n@*pn@Yen@{Mn@W ?{n@5cn@}Mn@\n@0գn@w `n@?Zn@Dbn@/tn@9Uin@\T6n@&Jr=n@(%냒n@]y wHn@[Pn@&qMzn@U-{n@X߭zn@n@n@"8pc~n@bn@_Un@7n@yn@Wn@\n@I3.n@# n@nGRm@nUm@zAm@>ϸm@K'*m@۴m@- &m@b:?Cm@m@}@b2m@enͽm@lm@bMhm@#Uawm@_MLWm@?Im@lm@sFm@zYm@~OƼm@yn@A$n@Fn@oSdn@;Xvn@^ t|n@Qzn@'o{n@2z n@ʉn@?13kn@z4Rn@Zn@A×n@zn@\:n@ܡ^n@V;#n@@;Hn@n@n@!&zvn@~H%UVn@9J7n@w*E, n@gin@T :n@ߒ.n@,)."n@{ya3n@,frHn@+^@`n@;Fu{n@b n@lNkZn@(dn@pen@w41n@ȈUTo@Z_%o@iI3o@&99K:o@? :o@ Irr3o@Ƶ(o@4\o@՛ o@n@m|n@Vn@Q/On@{n@@n@,0n@'>+n@]n@IUn@@Mn@iLn@+藆n@R)n@8n@T!:|n@atln@^j+Yn@QFn@ZE7n@.$o0n@(z}0n@2w86n@bq ?n@Fׁ:In@V$PTn@2^`n@9Qin@[>rn@o{n@ne'n@B+ܲn@iCSn@tn@)on@Xțn@š)n@אӝn@`n@ann@Wmوn@cr~n@Xn@`n@n@)Un@U|n@7mHٌxn@f]*wn@wn@r&zn@э~n@&in@;sn@[W={n@Zbn@TkAn@Uw0&n@ag$n@0o2n@t9n@U~m@=Cm@_YDIm@u$m@gzm@} n@fxn@n@O"@n@e,n@!魾n@ٗm@em@Ԉm@|Sm@Ǟmm@;/-m@L@Um@^)8 m@2 m@x|*m@mm@yc m@j,ghm@Ȏtm@]m@@YCm@%-m@#m@R&m@6[37m@vTm@"ym@E?Zm@w?wm@gUm@01m@lhm@:Vm@ m@yem@p"m@? m@ M7n@8l(n@^k6An@qUSn@CC]n@ubn@_n@9^]Sn@E'En@R@Bn@shJn@—Zn@@Doqn@wߌn@ n@xkp n@VC@n@?gn@1Gn@@ 6o@Eo@@8Un@2yn@_:n@4VNn@Zn@jµn@Nn@W)n@3LFn@Mqsn@$n@x4Jn@7n@1gHn@ vn@aЭn@I]\n@#Sn@"n@tT n@Z3n@[n@o9µn@FXn@%An@G$^(n@je_n@סP;//n@wYVn@ 1rn@_ռ"|n@+hoNwn@SSon@"kn@0|on@_xn@pn@gn@Xn@t>n@L*}n@On@Frn@QWn@ _n@!n@孰An@HU=In@{spn@!n@'[n@跘n@ sn@xCn@@n@Y}n@yn@idyn@[~n@; n@Npn@nϟrn@9@Zn@kEz9/(1n@+tQ6n@)6n@9n@D͛@n@In@Mm@W|3m@1J14m@0 #n@.2,n@"dxr;n@8B,` Rn@`#Uzon@CY͌n@J&n@Y.n@KNn@•|n@FE9n@KGyn@ƹn@kn@wpn@lD_ln@Cnn@]RDn@ H͚n@^={n@͠ 6n@{nn@'sn@+sn@Iتwn@"`n@%n@{n@LJe`wn@Zqn@3'<~ln@#fn@}hKn@{On@H7Un@5n@u&n@" %n@t2g=n@Cfn@ 8n@>fn@1n@Ln@#i%6n@evn@@oq&un@kTn@68n@ԧS?,n@;+n@{4+n@-SM%n@,ؐn@Z&L)bn@. n@Pn@=PRn@n@]V9 n@{EEm@{ym@B Km@~2m@cm@`-Fm@55;m@VjU5m@jehm@Yʕ#m@~C{m@cުm@ m5m@7m@ 1 m@4m@Qm@rêm@?m@JSʟm@%`m@t1ām@N>*ym@׻wm@I4}m@8OD m@8bEm@g0m@\m@0}'2m@s=m@l8n@,vvm@n,m@v">m@y&Lm@x}m@)m@-k;'m@a,*xm@Qc؀m@},bn@Z n@I n@:T"n@ n@q3n@#w8,n@{An@rmbTn@A%Fin@U-n@Nn@vNn@NBn@E.2n@jan@29n@x5<;n@Ӏ/M5n@WO|En@7Cn@n@R"n@mn@5Rρn@&n@%L n@ Vzn@IcG.n@\ln@ n@Bn@E̓#Kn@HXn@C]n@m%An@QXn@to@c|[o@Dn@.nn@"$n@`n@ Uvzn@0/n@Cn@RvYn@'dn@B'.n@&un@ [Wn@̓Ci;n@}rܝ%n@awn@2 n@>sm@Nom@öm@˜m@&ym@v^֟[m@=3mAAm@/-m@%#m@)e m@b%m@s 3m@8e cHm@qbm@ PX|m@N4m@Ͼxm@A6Km@Nn@WD¤JZn@W%@n@Lmn@u>ѫn@,On@O{an@&jn@fGXn@) Rn@e4Yn@DF6jn@ݢ~n@F퇡n@rn@n@Dn@pn@mn@[~Un@;ޭn@Ha|n@AWqGCyn@`Zs3xn@7`Qwn@T S,tn@sqn@Kpn@R̿un@Run@nךn@~cn@@in@*n@JXCn@LxBn@embBn@.n@n@qn@ԅ/Eon@HYnXn@”En@6H:n@r7n@5]ʔ{9n@\ >n@,aFn@dpn@w 'nn@y]kn@ {hn@]j3gn@dfn@(Fen@G`n@{\WWn@+vOn@hgCNn@uLRn@RZn@wEhcn@Znn@Wxn@ '(n@Rn@J n@Q8n@֝n@O;&n@hKn@u>n@T?'n@Qƿn@n@67[n@;}n@Q3n@ >n@f/n@36n@=n@J+o@+o@ To@Q\n@ּCn@=Inn@PWn@yl-n@16"8ʭn@Hn@tn@(ڞtn@n@ӼSn@gFen@#&^Ln@'p>n@9n@D7n@WK1n@cl~h(n@n@ˡYn@O4wn@'n@[$ n@S7n@| on@v}m@\vTm@Ȑm@[ m@Dz'm@%/m@1m@5$m@2CGm@l &m@]cm@7bqPm@Qٸm@"jqm@ .m@<1um@m@Ûm@Rmm@AǪm@3Ϙm@K{pm@Qjрm@: m@?ڎm@^hߢm@y1m@1Bg)m@Gz#n@iY]'n@TE)M+n@_}n@ Ln@)em@_ WeWm@m@!6m@{]m@AEm@Mvm@"m@\m@¢clm@Ǘ.m@h_.m@qm8?n@cX#n@X?n@aRn@ȶz]n@=hn@Rfun@*D"m@awm@%m@s m@ͽ$|2m@xqJKm@TsMhm@ZIDNm@닔Ԟm@1Km@MXm@/^ßn@vx`n@]̎n@ î~n@?&%n@l!Ơ(n@Mn@on@oI~œn@wn@J`n@jINn@)efAn@G^BEen@S%bin@ nn@=qn@|rn@rn@j"pn@5,jn@R+`n@ Xn@JҐTWn@]n@Zjn@5Fyn@,‡n@(Εn@5qNRn@!2Įn@wn@n@ ?$n@қcn@czWn@pģn@\|n@'4 n@A̡n@Ymn@cCn@\ShHAn@AyEn@bגTn@muon@on@[|)2n@n@CŎn@-9On@n@_?[n@+2n@5{An@h("n@z~Dm@jf!m@0m@m@ҝ0m@u vz3m@nMPm@mtom@sm@\Оm@Q`m@Em@QMo n@fJn@Vn@ }n@q[n@ gn@%]n@։n@82ln@J [n@˺3ӹVn@Yn@η^n@M en@ҊgUpn@/ڋ%n@eDn@n@Eyn@ 9n@In@/Cn@w[eܩn@@e]2n@kn@ިo(9n@wJn@@R1n@0ÿn@tkLn@|Zn@7n@OԷn@0Y{n@aupn@$~]n@V5Tn@I{n@O6n@0v*n@${^n@LWn@3s+n@&~n@Yn@096n@xrn@gbAin@D~n@N펴n@#@n@ZZ %~n@`GVn@bn@/$oTo@#o@N+o@r8v~o@Y o@^o@n@n@En@QPa۾n@'!꠭n@' n@ݸ`͞n@Yun@<n@.#On@4eOn@YTl n@a-$n@t n@kmQn@Je n@m@_Y%Rm@bm@|υm@og;{Xm@JFm@Vm@pm@⑮m@q&m@8m@VoSm@JGxm@Gm@=Qm@1]um@FET~m@O)g?m@f}m@O`7m@ m@K?m@"n@}@l7n@ﭽ:n@Rf,n@,Z5n@tz5m@grm@xÛm@Bɀm@"[8vm@ u|m@Em@?m@3m@-s,m@ձdem@R~m@>Vâm@mm@F(m@[n@*n@M(n@sn@\Qn@}2Pn@n%n@܃Fn@!\dn@#qn@43 =mn@jbn@uw_y\n@\E!S[n@\]|bn@Dj(=mn@ryn@5 n@-'~n@jn@3n@:3?n@Bdn@( qn@2jdn@Bin@Wn@Bkn@:R[o@io@U o@A)o@̖n@ ovn@&8n@Fvn@wn@5Cpn@Ljn@xQ2cgn@P4fn@yin@EErn@fa=n@6On@9ٗn@B5n@[n@Ɯn@yf8n@mtn@Lػn@ΫR}n@#Hxn@[#;zn@ n@^Iin@Zn@֠ ﵵn@btxn@/n@Dj}n@%ʌn@^fn@En@'n@s&nn@f n@B@n@zn@6"n@e̲n@=bn@On@3hKcn@Rrn@0÷o@Խo@ղ~zo@ Ŕo@?: o@so@/-=n@r-2tn@vn@gn@ zn@ܔn@|HAn@#9n@iw뾥n@M)On@@{]n@#n@.'n@\֓n@O/zn@UIdn@A Tn@/>Jn@fAn@IS8n@.n@z'n@6돸#n@P!s n@_Kn@ n@~d=%n@n@&ws5n@5Ei(n@??n@._n@gxn@@%n@Bo+.n@A:6n@K;n@J@n@TDn@ոFn@tڬIn@1O?Ln@aQn@>rn@"fn@Q[n@'n@r` n@ɯn@on@@n@lfմn@=i n@@<n@#n@x n@So@o@Kxo@xr@o@1USo@bD{+n@q|n@ϧ$n@_-n@Iܓn@n@m^ 1n@ *n@YDn@i@ɮn@IUZin@Qyn@n@FKʷn@o͸ǡn@Qn@Ab[kn@FYn@=bLn@mScCn@wV9n@YE/n@ =B'n@R$n@@#n@b!n@o;!n@7&n@˄6.n@TXc|n@n@ |n@H݂n@-yn@je{ln@@Tp^n@NӶm-Pn@D)F;n@&S!n@X Sn@[Zm@y *m@m^\\m@wm@[1YYcm@(ڇN=m@'m@G'm@vGQ9m@DOXm@Қ}m@0m@yEˊm@+m@ /`m@Ytkm@Bn@"0n@m|mn@>&wn@Rn@(Un@3Cp$n@vSUn@Ie/n@Q"Cn@S n@[un@1 rn@\ n@W`(n@tN4n@ᤗHn@E@Wen@ vGn@¿n@ܚn@J=n@4*;n@n@n@[meİn@A n@U_n@6$vn@Uen@pTn@'En@$@W;n@rU;n@~Bn@CL?Qn@0&bn@Tpn@k4Utn@w.in@GWn@6hDDn@X>6n@ Xw,n@:!n@WB n@h8}m@Vm@&Q͓m@V~Mm@!m@"m@Kn@5n@p n@on@n@C!n@vT,n@YN7n@餧F?n@gDn@xJn@N:gUn@&yfn@9w{n@Qn@;n@||ܡn@Ї 0Ԩn@ \Uzn@H| n@贡n@f!n@I5$Xn@e!*zn@5ktn@8qn@Fg}qn@Fvtn@+}n@98F"n@ьn@:z(nn@SWJn@̷n@m;n@EEn@ }n@8{n@lCn@9:An@ՆJkn@Sn@YP8n@2tmn@swn@Kln@n@n@In@-Nn@h m@CjHjm@Cm@heGfm@)m@bץm@&]m@tm@]e}m@8hm@@m@4n4m@eΦm@ [!m@;m@ּOm@Hm@1Km@ 9Ljm@`cm@ m@rHem@cbm@]Um@9m@ݲm@#*m@pnm@䯺~m@m@Tt m@+%ˆm@m@ R`m@s1=m@/'m@vm@.({m@Mٽm@x˯.m@ 鷱m@m@E+m@Nn@, m@?m@r \m@S>m@.]wm@ 4BI0Qm@ V( 7m@pct2m@61Cm@+am@;;w{m@ϵm@Af\pem@?m@BNm@ďm@x5m@In@} Jn@3eԁn@xn@9-TRn@PlG|n@aSp,Qn@n+n@ n@yfn@< n@zVn@T|+n@&T6n@%LOAn@e2D|n@ ~׋n@<7:n@an@SJLn@ r[n@IM.n@( gDn@}n@cFqn@Xv]n@R[?=n@鱉n@KCYm@\km@̘ m@$}Gm@˴n@< 0n@?@>n@p53n@_un@-Ģn@ n@n@?n@è]n@k*hn@Zn@f0Sn@Yjn@ tn@V50n@&n@>˺n@ ]n@<=1n@׹#ڳn@A-!n@ #mn@~-n@n@) n@ Q6n@֍n@mo@l@gn@؇n@s6(n@0оn@*n@a]%n@٥n@3&gn@牄n@A>1n@EBn@>0n@Hn@$on@,R0Vn@+ n@5n@xn@,70n@{X&n@1Rn@Xn@%h1Xwn@;b>tn@8N#pn@NOgn@@d[n@1iRn@YaKn@EFn@mT@n@fY%>c7n@@rgV.n@+>*n@㡖,n@w(24n@?c7A?n@S1_Kn@ Vn@۫z_n@W&en@z.fn@tCcn@xo]n@1@Rn@"|{UCn@n#9n@s4n@)}ƭ5n@27S=8n@h7n@@4n@m{0n@E A,n@(:π&n@<n@ɒn@bm@B_Fm@Em@ox,}m@VKm@r焰m@y)um@ k m@^-|m@%|m@ Em@`3vm@`" ;m@LPPwm@(Bm@Mϳm@|٤m@NfJm@Cc]m@2X/m@S1m@m@U1A m@+e»m@s9m@%ym@v\:6m@9 Mm@P8?m@>ܳm@7m@m@&m@Nx ؓm@8.Em@5 n@]L"n@~3n@9En@UO Yn@*mn@]|n@>7n@Dn@4n@s]n@aBkin@M#(n@r3fn@dsn@en@"˒n@Q8&n@n@ n@In@ pcn@^yFn@·n@TY7n@@2ln@"gO7n@LVn@L]Ln@n@/n@/0%n@|xTn@,e*vn@ejjn@WFhn@OX,on@Y#ɾ|n@kQ=n@Xǀn@?"|n@}xfn@ /gJn@٤%M(n@;km@z 9"m@uمm@lr"5Ym@1X9m@Wd4m@3Fm@Hx Jadm@?!m@ΡYm@6m@;ZjHm@ Am@:k@m@&Qm@9m@9m@c]n@Kn@s@%n@z:n@_ n@(e n@gL0n@.5.Pn@G.en@%H gn@.B]n@ DPn@8pHn@MU0Fn@rS4oLn@w1Yn@9hn@XxMvn@ I"n@P;ǂn@j>QT~n@U*nwn@܅\sn@\pn@NMJ7an@LIj@n@F8n@xm@ /wm@˹|m@x4m@F#!n@8c]6n@'Cn@ nn@މMn@9WRn@Jqn@߬Ҳn@/2n@Xn@fn@߰ln@ܰMn@׳/-n@R"n@0J$n@rI n@_g5 n@n@'n@,fon@ Jn@63n@hSn@Yn@Bn@k n@w)n@g81n@2dn@T$ܯn@hc"vn@yn@m?n@vn@ݰn@J }n@єzn@Ju.mn@S]n@&(Pn@Hn@gCn@9lum@vNWm@,v/am@TW`5m@am@?Im@-{Zm@)Dm@ln@^Ifn@(n@}õ.n@mDn@݉8\n@^pn@8n@)ln@r꥙n@ ׉wn@x1cn@a߾n@+᫸n@n@["un@ v~}n@y+Atn@O7rn@un@'݂xn@Jzn@~n@8փn@n@PՈ4gn@PYn@(1n@*sn@VDn@^ذn@bn@C1n@\}|-n@Nvxn@`fyn@W^n@t]Mn@;En@:n@Eƀ$n@2Tn@ Oun@3(eJn@-2n@_Hm@*ܧAm@>ATm@`\-m@@%m@8m@wHycXm@x]gvm@!h"Am@~m@}Tnm@s[m@}֍[|m@)hobm@7sɔm@j-4m@c/`m@CZn@RԤיxm@`m@ȹm@1>, m@v [ m@˴m@OAm@ Yfm@}0m@m@2*1m@?{m@>;Qn@|n@D>Ñn@{Un@Xn@KScn@[n@r9n@w^n@sn@o8n@(fn@]in@6ZYn@D&Cn@n@%Rn@-@n@])n@68n@(.0n@,+n@F0B-n@|:n@[ Mn@;-+^n@kGkn@&ztn@]1f{n@!Hn@a,F~n@b$vn@umn@@wegn@V1dn@*en@E}gn@[z'in@܆ln@rn@[«Rtn@-hn@S8Qn@@1n@*QCn@k3:n@6'm@Qm@m,m@4(m@YLp۲m@"P)ɞm@q=*qm@;/`m@p5m@%m@9m@GA>m@לSٮm@ m@6Nm@<m@t Im@G]m@0m@ WS˪m@9m@ym@(#3Vm@̈́)` m@Tm@5m@ ȁm@L*Hm@31Bm@Tp(Tm@sT7n@H#n@Zq m@bm@!m@ Km@qm@8cF9m@m@]ݴm@-tm@!ym@:tm@cDm@|On@ P[?Pn@IB!m@_*$m@iz]m@ɠ\2m@ܪ'm@tB?9m@=wWm@um@m@V m@zx|m@Rnm@3vbm@Gbm@-^Ȁwm@Om@~lhm@X n@;(n@Kn2n@-n@n@N} n@m@ nMm@&XCm@!Dn@҅qHn@).9lnn@r=zn@(@gn@lDn@{,!n@ZY? n@7wJn@/|e n@ylaYn@6n@wBOn@)E]n@\n@WUn@ )Un@#$;\n@Zn@P 3Bn@"cn@Yjm@(m@m@P13n@|ƾ2n@F9Mn@epMn@ikT9n@^e#&'n@7P $n@Y90n@eXAn@-ᖯMFn@h6n@ Xn@|8m@m@~[jm@$Vm@jX/m@m@@r_ m@\$Vm@pEbm@}"±m@PEm@"mm@Km@Ijym@u!m@8gW-m@+m@/3^m@~ Tsm@[}:m@u-m@ Mbm@`m@]Hm@_U`n@%d=n@pg`n@ Oفn@ΰ_Pn@%Sn@Hn@0kϲn@]an@Hn@/-un@J1n@-Qn@_*n@,n@ztn@$pP-n@oi"/n@wmI+n@~[ln@xn@4E n@n@n0$n@ 36n@zn@9 n@ja-n@W n@,;n@!n@Cγn@dٌKn@ǧn@=7D&o@o@a o@Ko@l޹n@I n@\պsn@Un@#^n@VIn@kRen@迯n@aQn@Rjn@O4n@k:\kn@|ϵn@P@on@ Tn@@wn@FȐn@qn@o7tGn@1<n@xgn@Λn@orXn@Ck`n@^Gn@n@Ajan@HSn@n@Sin@qYWξn@0un@k΍n@>yn@ 5icn@n@06n@gn@ڔn@}QCn@ѣtn@䯕e_n@Cf$On@+\Fn@]Cn@TAn@r b>n@h7)9n@@gE4n@qb3n@{;n@ .rJn@o=[n@n[ln@Qzn@ʨn@!ㆇn@™4jn@Gi,̂n@h7|n@$gvn@/_S.sn@WMqn@PNxzsn@ xn@F@n@xIZn@Pn@ϑn@xn@Wn@v;K7n@A> n@&$ n@U#Bm@)@Qm@xb/~m@}m@\m@JVm@<=5m@g:zY|m@m@=m@ep/^m@>m@Ķ!zm@[m@:n@m0n@si>b>Nn@RRdn@7sn@E]n@b} zn@men@\Vn@@n@QӲn@Qxn@uon@c2jn@vƋhn@fjn@L!qn@|n@P/7n@5'n@I}Rn@ ~ n@ēm@]5{>m@]qm@XXm@[3nHm@c @Sm@QXOmm@zz@m@knm@B3m@ vym@GMcm@/XTkSm@ʽnPm@^cm@4'm@G6Um@m@ˏ,n@ۚJ*n@Fވz&n@2n@}Bm@aߠ4m@ӨYm@]m@źm@&Rn@7Fn@$ (^n@_f[n@DN#An@7An@$m@|m@ ]m@ n@YH&n@OɃ+@n@M=Mn@PIn@eUm=n@;"t8n@z">n@݂An@\2n@IL.n@.pm@Y_m@CXm@' n@f0\F2n@dFn@4@n@)i,n@W΄n@&V"n@]ʫ6n@{In@s3?Ln@^u9n@_n@Zqm@a)0m@:m@mm@X4m@Um@q#m@ܨ+m@n8m@Em@ɼ m@!wm@ m@B2zm@5kRm@(m@im@um@{%qm@ݮJm@SѡRm@ۧCjm@v}gm@gm@+`qXn@*7n@/h)Xn@ _|n@wen@;fn@zTn@En@Gn@=n@¾n@p;n@>=yn@fOn@mn@In@n@%n@on@&wn@xn@do@4!Ho@M o@̓JMo@bo@% o@IH, o@9n@͞6n@En@9mzn@xn@nE%n@y=7n@ <gn@t`vn@"On@qdn@aWn@a.Qn@Epn@+2n@mGfcn@=fyn@ڕnn@{ln@5;n@ndn@4I}n@[@!sSn@Ĉtٝn@Ўn@ ñn@AFn@Mn@9ْn@yWn@Y2n@q#d|n@2n@%j n@6Dn@Jn@t{Nn@RTmn@n@0,ln@KB9Yn@cQ܂Mn@Eb4@Kn@daMn@x CLn@ySMFn@p$6?n@/9n@Ki8n@2>n@B)Jn@ԈZn@eݶln@ ̠}n@XE4n@Qn@M jn@Sqn@J*n@jVwn@Apn@w3ln@(vTjn@>-xpn@E~n@nrm@Hx`2vm@'3m@h l*m@6 m@P;m@45um@\m@$2um@Ulm@[g$m@m@Almm@]m@ nm@~dm@M9m@Y<|+m@O4n@nT.n@J9n@<;n@ʧ017n@_+n@0`ܔn@n@=8 n@FUIn@K-n@uhn@Xy7m@?gm@Nlm@u:Pm@A1m@Mhm@ eSm@@n-Mm@m@.m@רO"n@ȩʡJn@Fgx/gn@t_ yn@'*n@1VMn@^/In@2n@oSKn@xn@Jz`sn@*^nn@9bjn@ fn@hkrGen@e$Gjn@XAhDvn@In@t~n@T]uFn@:G?n@zqn@܅&pn@p@*Pn@GͤEn@y;9n@zn@~0n@)'(n@¤Bfn@/Vn@k%n@5Gn@Sm n@w`n@rk\b~n@ӝun@#Ign@em@$栐m@K|m@rP~m@+m@{xAm@em@xt2n@!0Z?n@8eІ8n@%n@[n@;/|n@r"n@I(|n@S n@/J0n@nC;n@e/n@Ӱ n@}8n@>>0n@d=\"Ln@~-bn@qyan@jHn@=s n@c9km@Ⱥ Wm@ ym@4m@Fopm@АJm@O m@ {Sm@k m@ m@+"S}m@5jm@1,Bm@9S)m@޺m@@Cym@m@=Pm@ {m@m@m@x/m@m@n@Q&n@o5n@'X>n@5Fn@]?Rn@gS+uan@u\qn@G{~n@#*]n@Hn@H fn@ Dzn@wn@7mn@·en@wF?]n@)Wn@^Xn@3ven@!xn@[>n@:C=n@T~n@en@/n@ 8jn@uIn@)Ăߪ+n@MГgn@:n@%TJjm@mm@_m@C]am@&m@A3Xm@H}m@>o0lm@ Xm@޲m@_Qgm@W4Q8m@%m@웆Jm@t)Om@fcm@m@•4L?m@q%m@.n%m@m@/9#n@Yn@Qہn@n@en@棤n@Uãn@jn@_;[mn@G{n@)tn@hG"sn@TPctsn@X!Znn@ YzNfn@}hp`n@Rbn@zwnn@&Lͅn@:n@jbn@܎n@n@a7ln@bNqn@j)n@n@<Ԥn@8ӂn@rn@,6f!n@Xn@HGn@'n@ד…n@Gn@F6n@>VWn@(1fun@͗/%en@ n@17Wn@Vn@:ODZMn@bt2$n@F(0 n@oDHn@\.#n@N0n@E :n@hC}JDn@!VTn@rCgln@yVn@ an@W/n@/Ī n@ UJn@m&n@TPLn@Qn@ۇ6jn@S n@FNn@JQxn@]UE n@_YbO#n@n@n@CjF'n@On@n@B1n@i5Yn@ii n@3=n@n@"n@}{n@m&qn@mn@)pW+n@a4s&o@Ago@3Bo@#o@u8'o@aw&o@o@mRo@0 ^o@n@ATkn@EOypn@;8n@X Ln@)nqo|n@m`n@Zn@)n@68n@@n@%Qn@^9 n@a{n@:%vɻn@~'n@}9n@?_n@Jn@W &n@dC|Wn@ ]n@m9n@&Vn@:S/n@yB3n@Ͳn@-Vʏ;n@UIun@tDFn@nun@D4jn@n@y4qn@1n@Ldn@^+Ȭn@.xn@Pin@Gڊ]n@HT9Xn@Ce/[n@RcmS.`n@V-an@IA]n@ Sn@uIn@)LBBn@qAn@.Fn@lB(2Rn@nN6_n@Wjkn@H gvn@ {n@PI|n@Vpb%zn@P-un@F mn@MCȽen@ˆ[^n@ŋ]uUn@}bsLn@P,}In@ʫ`)On@Le=[n@%hkn@Mԋn@C8n@tn@*A!n@F[Nn@ Ҧkn@`V3O[Jn@$*+n@$n@ʑ]n@4Ӛm@{ m@3Fm@pGm@!lm@(8]ԛm@Q=Wm@x-*m@y'm@Lm@՞m@Rm@xm@| 7n@X h! n@]0n@ 4n@d!:%Mn@9L]n@PYypTn@)&V 8n@5p'n@E4n@UOcVn@)Fun@n@Mf{IRzn@YҼ_gn@MPn@҉9n@#GO1n@_ݞ >2Xn@SDSn@)M=n@n@"{_m@5m@dKm@bm@m@%tӮm@I5m@x ikm@,m@3*n@EW5in@In@A>n@5Էn@sn@йnDn@˸n@0?Sn@Mn@Yn@<|n@e/n@aKn@0'~n@p(Con@ĎWgn@n-jn@4Yzn@r=Wn@fr3On@k9<n@n@Un@@7Mn@!JYn@Ln@vpHZn@Cn@n@Śn@%Vn@r ln@n@!n@/Kn@_7R5n@t46n@|En@1~lyn@~in@ [^n@S?Ln@`3n@үen@N8n@F8hm@htm@2m@7eYm@[ym@Vj7m@m@K ,0m@zKm@1m'm@Inm@zPEm@{;m@`Mm@bQhm@m@Ǣ s9m@Eؑdm@Uhnm@I5Nn@0{yn@IR?zn@m@h08gm@am@]0m@ķX@m@0e>m@m@;=n@*n@ XJM2n@GR_u"n@ln@*>m@Awum@Xn@#F&n@u9n@P$n@̈́n@6 n@*m@|m@HZm@(m@+m@"N>͵m@&_m@aBm@1}` n@c/n@J9n@ m.n@tb&n@O3n@iUn@𫼎|n@nn@P!n@[Ȃn@Et\n@ƪo0n@n@wm@t)m@ ^m@Pe[m@rbm@]-m@?p(Nm@Zm@zbm@\m@L*m@2Dm@F%m@'m@)m@C=_n@ݔ- n@n@n@^pi!n@iTBE)n@" 2n@qK:n@[Bn@-En@/}En@]:In@+ Vn@XZln@&Tn@Dz:n@BlhIn@yqn@3dn@On@!n@pn@ ϸֿn@vyn@)On@%;< Tn@.ٺn@EIBn@ n@Xn@9n@7f.n@FAn@bn@1o@:蝋o@Tӽ!o@;:*o@n A-o@80w*o@g| o@YKHo@wo@#sRn@@n@-_n@Pun@_;n@ݢqn@b+n@)in@9Tn@;Zn@Nn@"ԡ8n@NN n@ }n@Bzn@4 n@ n@B~n@ >n@\n@Yn@d#n@CQ1n@͋n@,V n@nn@[#n@on@ ? n@:Ln@vRn@6n@qnrn@S vn@³Q5n@/enn@n@n@m1n@TP5_rn@{in@Rwgn@Fڧ*jn@$7Smn@a`hln@en@Y4} Yn@^DLn@Cn@ngAn@\Fn@}Qn@me]n@tfgn@won@L]tn@NMsn@-Stpn@)|fln@8Rhn@6Cdn@ȽR^n@)11Wn@KMn@}Fn@qCn@bFJEn@wW>On@^dn@EM7؁n@;^n@"-On@9|>n@0 n@k<dn@ Cn@K$o(n@h n@ f>n@5cn@)m@dZm@]:Zm@J1m@e=~)lm@}dm@~]bBm@bem@$w n@Gn@iɾn@ n@' n@bn@3n@8ESn@ Φnn@aEln@On@x;08n@#Y>n@pE]n@^l|n@2Χn@R/g~n@7՘en@6T=Fn@.n@#I*n@˩j:n@hLPn@*_n@%m^n@ĝIn@5O|&n@p-?n@[m@4̊/fm@+$m@6vym@ zRm@7`幑n@x<5n@An@݇?n@]mn@w+n@0rsn@>'kn@_nn@γyn@96bn@OP;n@E8n@B[n@$n@-Kn@P: n@JjUn@2:n@`!w n@ca!n@VKn@8yn@ĂHn@Fxׯn@Od<n@Ӭn@; 6n@An@ؐiAn@un@{xn@@9/jn@}@Qn@\͸7n@zP!n@t{ n@.0-Um@;\5m@:Rm@m@\dm@TJ;n@""n@ ؋m@|vm@7eGm@D ١Wm@FS/Hm@DVm@g98'jm@N¿zm@ӥ͊m@&%6:m@NLm@;f`Km@ u|m@JN- n@ m@cm@9uYkm@zim@jˡm@Cym@)DWn@(-n@046n@ o@n@D1n@VNhn@jem@>m@p+-n@0 n@1:%n@2+n@:n@M n@| am@m@>m@1m@-6m@pO,m@v*?m@sTiPm@B$n@y4En@0JbLn@R7yyFn@@KHn@%Z_n@0Ƚ΅n@4n@n@Vqβn@[zIn@.kn@qJ`Bn@]+n@n@w}m@@m@;CRm@ ,wm@"Wn@Bh* n@@C n@ƙOvln@k{m@m@|m@gRm@Lm@Jmn@[jn@вwn@\7Ŷn@'Y.n@@wT>n@!r2Hn@_g۴Ln@ CMn@dnLn@+#iIn@KDn@4*@n@rxTLBn@-On@}.i cn@fߘvn@`1瘃n@Tn@whn@\n@1Sn@]*zn@K>Mn@{n@G-^n@釟n@e5Zn@1ͨn@#n@C"n@Wp$n@3uCn@t/En@Wn@TD鬱n@ȸCn@n@F n@b"n@)+n@d8*Nn@;Oo@: ao@Io@U}+o@lo4o@; qn@=7"an@CQn@MevHn@]o6Gn@Mn@en@Qn@8cn@HĽn@4?w%n@WvBn@ I`n@1Wfn@bzOn@Re5n@AާB4n@||aPn@_pn@}n@}ENsn@6* Tn@3 *!0n@O,_n@ܳn@)n@@>n@8Mn@UօgRn@gDn@ %n@5wm@NLnm@-m@8lm@;7ܚm@J;m@ nǓm@,Mm@tim@m@+ӡn@PwfAn@6rdn@ n@7n@ n@[חn@Cێn@aZMn@4mXn@Oan@Rn@[xn@B࠳n@.౶n@6@n@hZdMnn@7pz9dn@qzbn@åuncn@ě;fn@6Rpn@XIn@(:n@8Hn@yn@A{Fn@ n@r՞qn@~Pؓyn@2;/qn@ۮ>҂n@ܝn@Zr n@n@ɟ(n@\{|n@&<n@)?B5n@/n@Un@Xqɫyn@]|gn@9wkLn@߁!1n@C7n@*m@lm@_Jm@FOm@p=2m@֊n@'$n@oάn@># m@'ɶm@HȂm@K8rm@JD}m@:m@ⱱm@܍ݎm@{'m@0ͭm@8 m@6Œ m@IIm@_|$m@m@6*/[m@rkm@Rm@ق9 n@n@uK'n@(Cn@YNnpMn@ţ,n@;mn@n@n@+]n@>JLn@_cn@.Rn@'Rbn@[/Tn@牗Tn@8mZn@adn@tmn@Z/Qtn@c2vn@un@Zn tn@7sn@ Nusn@ Gd?qn@CvXmn@a%jin@ dn@şG[`n@\n@)Wn@A%'Sn@ͨ"Sn@Ŝ\n@m7pn@V!n@% An@c?n@{Un@Յsn@mJn@JU(n@0!n@F#n@nI1n@{~3n@<͈Yn@ m@F-m@(m@d)v]m@:um@`'n@,n@/n@nsTn@g n@ 2 n@@Q n@_T^n@"R$n@L켬;n@zXEn@mh9n@_, "n@~sn@ 8n@']\n@Cqmn@8awan@@n@ -n@1] n@?2 n@99Jn@j"n@qV@2n@F?n@X_n@tn@aRݙzn@!~vn@$ۺon@c$lkn@9N`qn@C`n@1 n@:zn@[صn@]WÇn@ jmn@Vr k]n@zUhbSn@,}/Jn@v>En@Q8GQn@.ѱon@On@D޶n@ڸcn@(qin@[(]n@Zs n@X1"n@NMY:%n@/&n@^z_#n@sn@N`n@N*n@D%nfDn@U> Udn@y#n@ۻn@r:n@K-n@+K sn@iCcn@K3]n@pY\n@( ]n@ػjU^n@C{Rbn@gYin@ׄVnn@ Gmn@tahn@ɮen@̡-in@ tn@Sn@n@BLn@A9sn@yn@FM]n@5n@on@F&rn@jήn@{hn@/1in@m)n@un@\n@^n@#Mgtn@X͒n@6| o@.no@d:'o@4o@]ά E?o@_%Ho@Mo@3ݾIo@W;o@ C&o@) o@RmTlo@\!o@yYVqo@ߡa o@2o@ao@@n@fn@˝bun@Y(Lln@lTn@utZn@^Etn@gn@|On@ꝟn@#Mn@keOn@lVn@jwn@2T}n@WD[n@wq;n@֓n@c9n@DHeEn@ ?n@#8~>n@klSn@W֜n@xLn@+~n@';o@Z(Zn@Vyn@Kl:n@/ Nn@en@ n@c-6n@p n@l%n@)n@rYn@ )݋n@.mkbn@_Eyfn@($n@ #2n@5 m@+ m@QICm@%n@Mpl n@(p n@_gn@c*{m@M 9Tm@Hm@Q7m@Bwn@Kn@V[n@6n@yv[n@n@kan@ԓFn@P8Yn@bNn@cnW$1n@cn@6n@ n@Zĥn@zs n@K!n@hXqn@l8n@[߼m@( m@Cm@:m@Ɲ" m@,im@Q?gm@u7om@UiUmm@]Um@jm@S"Em@Y?am@xA@m@Ď?ikn@np&n@@LEn@⫊Rn@2uRn@u$}In@5;yn@QPn@4n@J>-9n@*]{\n@n@Cn@Δn@}n@Ļn@PHn@n@QdDn@fqn@!3n@$tn@ aUn@T4n@IMn@m@t24m@qV{m@0܈m@QH>bm@ĺ~n@u2n@uPHS1n@bNLn@:Vmhm@|#Bm@b_m@mn@m@V m@f3m@B0m@ m@7Lxkm@s"֮m@)m@R3m@A"iPm@OG&m@kpgm@@#om@3fJm@ n@$n@=7Hn@"n@kwhn@jExn@&Pn@n@RY`fn@1Tn@D]#IJn@RJzCn@S2?o@(9l-o@~vo@'Zo@o@o@o@bfdo@}o@S:k o@~- o@Ikn@]Zn@*8n@"|~n@mn@[l5n@@\n@i\n@` n@!5xn@:ͽn@n@Ǎmn@-6n@O!Cn@/n@Șn@cn@6T}n@n@1qn@>#n@+o@鰰 o@,q7 o@DC.o@~n@㕏n@$0n@dYn@V>n@u (n@F)n@ n@-'-n@/jLn@ Nn@In@1])|ۄn@U%yn@%a^pn@?ln@Mmn@m(pn@6 |vn@n@afj9n@C!n@nn@FTh n@X-Jn@vn@jn@|Eun@m9n@)Ƥ7*n@{ qn@xۍn@ׂn@/"n@Q0Gn@{d @n@ї˙n@O9-Fn@fy[#n@y!n@B_n@ n@s2gn@jOn@/GmvJn@@z~On@_mRn@O4Kn@<_9n@"q^,n@C 5n@oÌm@mm@^m@¹ϸn@/8Ln@NY?*n@-yਔm@&{m@,-bm@Ï-#m@@dm@m@kQm@,m@ t m@n@.A61n@~߻(n@ϰK&n@,n@8n@YlCn@mWGn@u?iGn@xHn@=`?Qn@(,fn@n@ X:n@V}Nn@n@4sn@¡un@?ؠn@2cn@fn@)}Ln@e9ón@VCLn@u~n@Zn@wn@0'ؔn@G[n@jwxn@5_ =nn@.ln@!$h#vn@j|n@Yn@Sn@7;n@Zxn@Xn@ >Sn@GG`n@dVn@yrЉo@Co@Rx%o@1o@ [#4o@N64o@ }5o@gJ:o@5$p>o@RE;o@J`60o@mY,!o@6GCo@-Go@\$o@E.o@="/o@u2R&o@{AQo@i}o@|ZFn@tHn@s=n@1վn@?U[n@'c,>n@e5Sn@!n@S㒲n@8{Ԭn@,ϧn@n@PM͝n@ >n@[lɊn@y{n@!yn@P \vn@>yn@ ˶n@[n@czS;n@ Qn@xn@>hn@(kn@dJn@}WJn@3ݧn@dD?䅘n@)ߊn@& 7n@n@hl`n@]n@Oʃn@7Ʈqn@q;qn@n@n@v8n@cdU2n@9 n@U9͂n@/0akn@}fn@9$=fn@5C_n@dSn@x4?n@S%n@fؾ n@-7Lm@i{m@iyOm@[\Xn@n@ 1n@m@:3m@m@_O{m@m@Lm@,bam@Ym@m@Oxm@HgNYm@FYn@g$n@.0"n@DžyGEn@Fn@=on@qY\ n@NrKpn@๝=un@t* n@t]m@lm@Pm@>\tm@eTm@>1ym@nqP`ym@Y.cm@ov0`m@2pdm@8gm@ m@ 'uvm@y^m@vsm@:~qm@km@ m@m@w&k)n@n@Pm@D{m@{m@WfBm@Y ]!n@::~_n@,ʕn@In@dn@ay>n@'7 n@fbn@byn@٩r(n@l,;Q5n@K=n@్Cn@ Hn@ En@ 5n@؜/n@J`On@w#삘n@ 3;n@Nmn@({w=n@.un@]6n@Gn@WOn@YmNn@nu=n@K׿n@H7n@3N%n@@`n@h%i=Q?n@̯cn@Vm@d>h-m@ۺNm@^Am@mUbm@Fhn@J n@N n@Gu?n@o8n@QU"n@liMQn@oin@X2c`n@Ln@n7n@x n@yDwm@m@J4m@ro&"m@Zw:m@ҏm@24rnm@m@').im@m@uܴm@RV^ m@R n@on@p)"n@6ln@m@iIn@ MBgn@YWn@ʗR`ߪn@*Rn@",Mn@փFo@Z.)""o@NɈ|o@ۣn@ڊZn@Hen@Cn@fn@PXn@Dn@htn@s^~jn@,Tin@%8=hn@_`n@x!Sn@Bn@%eq0n@(%n@ A&n@*0n@<d@n@_Nn@d<Yn@)95an@ܽԾkn@{n@9lAn@:ǥn@ n@23n@V4n@! `n@Bŭn@n@n@`J"n@rn@l-n@Cl^n@ Ln@Fn@>e(n@) n@#n@57n@6`7 n@ 0n@IȤn@Ȅn@‹n@ `Hm@:WVm@gWpSm@^Rǰm@IJ۔m@ m@с5m@F9)m@⑾m@M jWm@f7m@#pn@Jy$n@A5n@ мn@'!n@=^*n@Q*RB/n@mK+n@ **n@uzm@+[m@0۔m@Ap-m@sփm@m1um@ ˋsm@3 ~m@e am@ K)#m@m@뗠m@\҈m@IMm@E#/m@pm@Z}׵m@!m@#m@e" m@C5m@sm@Dm@Em@m@| n@зSHn@J4un@dzzn@2MAZn@w\,n@9yafn@'Vm@w n@,M % n@On@PBmn@in@ $Ln@S@mjn@D! n@gbm@m@"Ňn@ˁn@qQn@iu=n@06un@E n@[Ӡ5n@z+n@n@6n@L8n@f#n@æn@tavn@+\n@M#Vn@s&V( n@!o@3h o@|eo@Ԩo@To@?bo@s$o@їF0o@\Og5o@ڍY0o@W"U"&o@ȪO!o@BaA(o@7o@:Go@Lo@ "\Co@T#:/o@:Mo@Vn@fn@Sn@u#yEn@Vn@*n@kn@H:齕n@ y-,֚n@=V`n@g9n@&n@LT:n@n@|a_n@#sn@~䞠n@Çɤn@Qn@vcnkn@͛/Ƭn@pNQn@|2Jn@Y^Un@O*an@o?n@2n@@n@;P{&nn@i\Aan@^n@4?en@`6mn@Ǥmn@MgIen@@!]n@]n@_fn@Jݓgn@.Wn@HM>n@ ŝF1n@"KQ9n@`Gn@j99Rn@%YiXn@k@9Ln@F0n@>ԊN*n@H}= n@n@զn@|6)n@8/n@Sr=(n@;Nn@hm@8m@ 6ݼm@rD *m@4Mom@~hm@W^m@ im@1FXكm@}|ڤm@6um@ /m@wSn@S7n@&Mx-n@wDg=n@%R!In@gmQMn@d+Gn@R2Q1n@e\n@*'m@m@cvm@)m@7}m@@wMtm@n,ۏvm@m@^(m@[Ém@yzm@cNm@73vm@CR8@m@wpm@fNm@bg+7m@fڦ×m@am@cqn@3?n@\7\dn@$;'gn@3 Fn@pO pn@߼gm@*^m@Eu$m@w!Dm@J٫m@Knm@쒒m@4ZCm@<m@Bs|Dm@1@=m@ ҁm@,֧ m@Ym@05n@>Oijq m@m@FPum@}m@lm@9^n@* n@D#n@چ m@~m@4[lm@!e\m@_}m@lSm@u.n@.n@ZN%oDn@4o9*WBn@TZ /n@@Pn@Rn@sz/n@0Kn@2uhjn@\4n@̬I}n@k\n@&X9o@6uZo@;(Oo@iw1'o@[&Lo@xn@.''n@Hn@uCn@؃عn@H|Nn@8^ѹn@SI"ȫn@ n@ n@aXYn@:n@D<'~n@)]jn@p'Qn@!%Bn@1=n@ag?n@]Fn@ioBTn@sD:gn@|n@n@.Ybyn@C^%n@5n@}Eun@K{n@;Qn@#'n@,n@a(An@3B#n@G6\n@Syn@d &n@n@Ӧn@sn@˒5n@r:.mn@ѐ n@޻1n@9%n@x0ލn@5@[n@b7sn@On@\J7 n@n@5 n@ln@Lp!Un@9an@mO$W@n@Ln@F³n@Dn@wgn@ʒ*~n@ZGLn@on@<Q,!n@kdn@ Z`o@Dpxo@!C}o@o@P 5-o@u@5o@}j1o@K)o@mZ%o@'ަ,o@\l=o@-No@ȔTo@bLo@8]Q;o@524&'o@ eo@Ȉϐo@\n@dyn@# o@o@Bq,o@tLT^'o@rio@Un@_>an@no2*n@QGon@0z1n@`Un@eG 4n@,{ho@cP o@{&o@Gx(o@5Y'o@kOC4o@\D#o@W.Cn@f'n@=Pn@Pn@$Tn@nn@n@}%nn@n@[Qn@@En@9˅pn@pn@UA'H%n@бn@憋n@Jn@CL{On@>xj:=n@Te4n@YLwn@?( ޡn@nn@4Q>)n@Rg>n@o&n@in@ (,ۭn@hʹn@H yn@Nn@:n@W\rn@)in@*lUTn@)i?n@1pEn@tg8n@Du dn@Lm@K9rm@bzm@Lsmm@׃qm@h[m@ Cm@ 7kbBm@EXRm@km@$m@4m@,~m@ Fn@/=n@a#Yn@R=gn@=Ajn@Yan@P Gn@J n@e'm@Nm@qm@BKm@kv_m@{ ym@ Cєpm@?tm@Ğm@!_Sm@m'f^m@Ԭ[Em@ Km@ >km@Jm@D4+ύm@N`Җm@:>m@59m@bvm@1Y m@UZm@̈҅m@jW[n@ n@o Un@!_n@|dɮn@2mn@n@ێun@~in@nnRfn@ ;BTen@IVen@FJfn@Wd#ln@K{zd{n@ ͑n@Rnߩn@"AP˼n@kn@$/n@nn@nَHn@Vjƹn@4?lKn@n@}On@ѫy!n@sT+Un@cb9n@K n@{n@mn@W`n@꺼n@nn@L+n@f9n@#߂n@]>ώn@'Bn@y￳n@]n@Tn@J^Pn@r`n@EWn@ѿrn@-sn@x)s=n@+>[an@En@ωn@::n@ en@U]Vn@IXgn@Dn@!]2n@k/Rn@/'oqo@f6ͭo@H'-o@b5o@o{93o@B39:-o@W̗%y)o@U /o@%=o@ƖpCMo@QA,Uo@Po@t[Fo@*9o@IW)o@!o@-eFo@֮o@ Ěo@@z/Zgo@%ոo@66o@ o@Oo@WMn@pEn@v01kn@tx?n@_&n@ye>o@~Uo@h߹*o@ma?a/o@pUѿ0o@TՅ,o@hcyo@/ o@X( Rn@ \n@$$n@Tn@#3n@vqn@.)n@BMe n@%y8n@q'Σn@u=NYn@6'cn@Zzn@Uk5tn@uEqn@rS,rn@0un@ˢ` }n@ͺqχn@yaԐn@!5n@n@wOn@cRŤn@N +n@;&n@DG҅n@n@yon@ɓЬn@IIn@Gn@[-ˁn@_hgn@':^HNn@nLd~n@~]7Vn@+Inun@mfŢn@}n@3;n@ޘn@ތ*gn@W@]n@e ein@=Bn@!܀n@m@y^m@@e$m@fOm@h8dm@ m@灧n@0W(;n@?AXn@^n@En@o~Wn@`|n@ɦPn@iNn@Õwn@4Rn@%xn@ n@eL0Gn@En@dn@uҿn@7~Gn@ }*n@n-yn@ apn@0nγn@m.n@e 'n@͑ n@$n@\n@_Ƴn@s:ʻn@b/[n@A n@;n@Bn@WGØn@cִQn@>n@n@ڽȣn@;C3en@eaxn@6n@bO @n@v4n@]Xn@ n@n@C ,n@=-n@Zjcn@*jn@˭n@?o@74o@5`o@oZ7n@un@м=7n@XgIn@"n~bn@?cB{\o@)o@.m6o@>8':o@V;o@65o@0f$o@N!"Ao@F5"n@ڄnn@ #n@Rn@n@ n@Lqn@oH7In@;?ܶn@Tân@hPLn@-'Qn@qn@ Z,en@k^n@Ns[n@g"_n@Fhn@musn@,?{n@k!n@7mn@O%n@Yn@Ȝ<ܧn@ +n@ߟn@_n@Wrۘn@}͙n@on@99dΏn@)݀n@vln@xpTn@>n@k:u4n@MEA5n@.F[3n@BYp%n@en@Ln@gۥ+Qn@.vmn@H{n@ mn@Kn@O"n@JkQm@\em@4 m@n@謤u n@yym@3vm@Gtm@^ќtm@ލm@y/xm@¸Tlm@p.Jnm@x }m@Gtm@G5:m@M]im@xɖm@Km@z&vm@Uqnm@5rm@o37m@#m@Mnm@!+m@(-fn@uqn@ti0n@=]H=En@,j=Gn@U0n@:ϳn@#L5"m@ƻwdm@5+m@rpum@{M m@5Y?x}m@E)Wm@!y.m@‰Zm@%Iͫm@em@-!m@um@VBm@<4Օm@ym@O +m@V FOm@Yڨum@_ȅm@X-ѷm@m@fem@ߕ#!n@=|iSn@@1%ln@-W9n@YÓn@u#n@bn@\9mn@ p+n@Tjin@Aε&3n@\m@XHajm@um@HhD#m@O02m@ Lqm@VAm@Z~n@1L,n@:L&D1n@;&z)n@nʹ"n@A#n@41&n@qp;n@n@kDnm@qq%m@ZDm@J_Zm@A/Fm@Sm@d]qm@Wgv3m@';m@,m@m@^bm@l*{n@A%n@1Z`n@?Qn@$~v(n@Kb0n@No@co@v% o@7̍o@4eo@3h7On@tn@RR~In@E,n@èn@-Œn@Un@䖣xn@ n@:n@[n@ܑfn@u vn@¡WFn@ˣn@u^|n@$n@n@=n@ywn@Y.>n@o0Un@=| un@Xa/,n@/n@wMMn@Oygn@Fn@)n@Dn@Wan@ gn@'6ِn@DYn@kDn@Y n@aB"n@N&n@;xn@NY^-n@n@2)ln@}Jn@ *n@>n@)AJ0n@KQn@(Hn@99Lfn@~n n@< n@+Hi n@7!n@3@9o@h^o@$)o@)21o@piqf0o@m+n+o@ô)o@ed5B1o@Ң^?o@Mo@)Wo@Q[o@Ef]o@f,Yo@T4No@$#:=o@R 1-o@-wo@juo@㽓 o@`"o o@\0 Go@۰l o@ 3 o@UTNo@vuhn@3,.n@n@,Qo@D na&o@^:o@GZ_EDo@WIo@`+Lo@MDo@0o@o@l o@Njn@̾n@> n@)`n@"%n@5on@n@gm)n@Ipn@_^n@m@/al@!l@pNm@&p(!m@2$\,Wm@ ׽ϝm@5҃Tm@тB'n@0jZbTn@ an@YuMn@tz$n@ m@U:m@G4-m@퓶#m@,vϦm@$mm@} {m@9%\om@KaSrm@yIÄm@:>m@QpIm@3:m@[fGm@oam@rIwm@ jm@yAلim@ɝ#zm@<2m@r2m@3Z%Wm@'nn@5+n@^An@8Ln@qQBn@jp#n@(n@/m@1m@&m@:$m@ċm@7idm@⍛@3m@ɺm@jK\?l@3<~l@~l@4 l@l@l@N\l@V7l@Ehl@m@áC(m@7cLm@etm@Fm@\m@=m@rn@.L\n@bޑn@+iצn@:,,n@3n@kn@n@+n@Gm^_n@L} %n@#9m@ґm@]m@Fϝm@!>S:m@eN{m@SAm@km@>Xm@'km@8cm@澲um@ Bm@GJ n@;>RA-n@a=9n@u_:n@Bn@!lkZn@DMfn@3DBn@!nn@.Xʑo@ECo@}ogo@pP}o@NIpo@9o@=?/n@dZn@P^ln@وn@Sٓn@ax5.n@}n@0ӝYn@wn@Ln@n@*[o@1.Zo@;,$o@)c*o@n@n@ĢV n@n5n@2ǒQOn@$&qn@l8,n@ߧn@`=$n@y|9Vn@yUI|n@1Ssn@ >mn@Sen@,"_n@;`n@Uon@((n@ͬyn@H݁jn@f(*n@cSmi̤n@A8Nn@%Ӓn@kbOn@rIn@Hn@!{fn@& n@iZn@n@6n@ޱHn@^Z!n@dn@n@\ n@L1wn@NHkn@& n@mP8n@=Qxn@\ n@[5(n@qn@xY!n@s Do@Enpro@Dx1~)o@bJȦ1o@Ԗ4o@;Sc4o@w`65o@Amg=o@G Jo@n7+4RWo@bo@XVSjo@'rglo@/m\ho@X[o@^Go@ %3o@"o@@o@m<o@U\So@Wo@2_׬o@r)o@T%f o@xCo@e5+ o@\e:Ho@0)o@ }>o@ԫLo@ ~To@GZo@e^o@}Vo@60Co@y1o@V#o@3o@3SV|o@]VJo@?,[o@&cNo@ln@z4n@bxn@Їn@ m@, el@E=5l@6 l@y[ m@g:m@p[tm@te0m@"m@.n@PxDn@o,7n@ ٦xn@!ȷm@$m@@>m@ZNim@UR/m@1xm@>Rདm@qtm@o#o~m@/*ݏm@m@ɷѻm@Zlm@ͳm@ڸm@~m@&) om@oUcykm@wum@#m@6fQm@ m@O n@SF\/n@KH>n@ =n@}S/n@n@ϵFn@%-4m@!b+m@ 2ım@fqHm@Zm@D7Vm@Jz~m@L Pl@Qpl@xl@ɸl@yCl@^l@a$ l@Gfl@g.[l@!Fl@)2l@el@ygߪm@U Am@n3Yfm@f!sm@Ϳ9Dm@sZm@Z}hRm@Qݕy)n@ЃOn@8LNn@uWn@00vn@A m@ym@l׎m@cm@2HԦm@Mm@/rm@m@ =6'm@?Xm@) n@3PQ n@r<n@+y, o@9֏-o@8g>o@s3Io@G[΅Qo@fVo@eWo@~\Mo@\44o@e# o@U0[Xn@:n@8un@ğn@un@['jn@TRz%n@L n@Q6n@ehn@7WJK"n@arn@d5en@ԗZn@BS#gRn@B'Ln@7Nn@K81]n@ڜݡ4wn@bАn@JPn@@ƨn@n@jFLn@ gn@ 0 n@zؙn@"R֢n@b n@}g`n@ƴ`n@Ofin@;]@n@jo@nG o@!o@"~Dn@V0In@}cL n@KEn@=gwan@ Cn@bn@/Yn@2=yn@CFqn@o@%fd:o@re%!o@#A.o@̹d9o@jcAo@cFo@1Ko@zgSo@S{\o@go@nCjso@%;',|o@yw ~o@.'gXuo@Nbco@8u$Mo@LS1P9o@'o@c.(o@Fa%o@ %o@Z#o@xȾ o@ZSo@<&s{ o@8Y#+$o@tB -o@8 AW^;o@[Lo@V Zo@z 4ao@  fo@mo@xqro@Igjo@|SSZo@t-Ko@tkW=o@GY90o@ #*o@N4%o@8o@o@Sn@́_n@ n@yn@a n@E 8n@_Wn@!+Hn@E!/vn@(H&dn@{ɴ[n@e!) Un@kyLIn@s˭:n@+0n@~/1n@Z;n@IHn@rSn@H[n@^n@k%# Yn@T׾.Qn@"On@KVn@)8¾hdn@N45vn@xB΅n@9Rn@ ynn@Fn@!n@0m@~m@L m@Opm@^8gm@m@:ku1m@\_Im@z{m@' e\m@`dm@/T0lm@N6im@Qeom@ m@xhm@[un@-n@`+)Yn@=n@Zkn@an@j t^n@fv)n@lCm@omm@eF:m@~w{m@j6O[m@=m@Ub m@Tm@6f>"l@ l@7m@Yːj8m@0gm@Y&Km@)m@kn@>d 3n@:=/n@u;n@q n@.9n@n@o$&m@j m@=.)Fm@' m@Zߖm@9߁m@rcm@sٸm@Idvm@=Iƕm@nm@%# m@*?m@18ym@z sm@t|bwm@ Mm@(2m@W m@,I; n@S%+n@o.n@Ц#n@;ڜn@(ق n@`tTn@m@ c bm@=Qm@.e1m@\,3}m@EKm@ HPm@wnP l@#Gl@ڂBl@"m l@5<8.l@ksl@dYJl@ǘĔl@<+l@dS|2l@w}t!ql@{ml@l@8 :\m@j+-m@e5Hm@Rbz{_m@zv}vm@“1ǐm@]01m@_(m@X=9 n@gCn@J/}n@5~Ԁn@礤n@LTn@:P ˁn@3ćGn@(%;n@ \m@!jm@oDm@1m@k:zm@xm@q8~m@8ATm@Gm@,0m@\/*n@.JLn@OkTd:n@Pbn@ج 1m@37m@薵 m@%om@n L(tm@Wm@&Hm@GMm@xcm@B"w>|m@?anm@_)(;m@άm@6IQ m@zm@${| m@2!Mm@JHgm@X5j n@mj$n@"n@ȃ&n@$'Bn@8J3in@kQn@t0w'n@+Vo@+YDo@bvo@Pao@kõHno@1E9C/o@qL0n@FCn@3wn@Ygkn@oٰun@*n@YqNn@MMGn@rn@H\MϦn@<!n@Wbpn@htn@WL>n o@ih'*o@gdDo@ȐYSo@Yo@6[o@in@N:_n@^vAn@.to@~o@Eo@l/<,)o@?H6o@86VFo@cDTo@߽]o@06co@8!io@- qo@9/Ӓ{o@o@~sI5o@2(kNo@LC|o@/5`go@ :sRo@{ Ao@s 2o@]Ao@C̣?o@>o@Š;o@8o@W6o@J9o@h@Co@oQo@ vo]ao@e~oo@vo@4.1 xo@,yo@8\o@>̏*o@^{o@;oo@:ދrdo@\0Xo@X1Ho@yaB;o@h.o@Į o@;ro@FYgo@Ldn@ϲn@pn@hn@5n@`Pn@)kn@Gм;n@ 1nyn@[N1qn@Q[iin@>[n@wGn@gFQ6n@WnU/n@hЗ5n@jVCn@ Un@BV&dn@եhn@bn@IRn@1/Cn@8X=n@+fFn@r>)_n@BǶzn@#Q n@ sn@RM8Ln@8-n@-m@IIm@Ƌ m@׊,um@um@&;wm@ pm@ smm@磌ym@[9Lm@F*Vm@XJBm@_vm@F/Gm@Am@A˭m@۲ym@ zn@ȭ0n@6Zn@@pn@e>in@6Nn@Z)n@qn@(:m@GKm@ܱ!ȗm@vBˁm@_im@8WyIm@!*m@m@O"m@}d5m@ G0VOm@9(tm@y/Kcm@)Շm@pE n@73h(n@\4}+n@sW"n@W"Kn@=yn@,ҵ"n@kJn@h n@`v2 n@:vm@sh3rm@T3 m@xm@.Dٕ.n@˯an@Uݤn@]tw n@IHn@zgn@51n@*Fm@ːm@aa `m@<_m@(Hw{m@)am@VKOm@fMm@b6km@׈Mm@"n@,B7n@IM:n@`n@7Cam@3w9m@Z=m@p Z m@50=m@>D3um@UWm@^>Sm@ bm@66zm@ϔm@m@D%تm@d>Ym@J`m@q(m@\)Sm@Vm@8@Zn@rin@mn: n@(^n@4n@[t[]n@n@~9hcn@ n@ 23o@~fbo@Mnrn@Zn5n@0|љn@s)}n@&dwn@1n@Ĩn@J߷ߞn@ ]vn@+n@vj0xn@#\pnn@KNln@a8pkn@h=!in@en@(Ro@6OpTo@`o@dpo@)cpo@Fqo@1o@)!/o@.M)+o@ג .o@tyËo@*o@mvwo@ÿ qo@i*go@Dn@Cn 3n@Ak.n@Ĝon@gԠn@lۖn@Y;,}ߎn@U #on@jun@k'`n@uoSABKn@QP>n@"˽=n@((In@f<'d\n@R kn@qn@wO=lkn@MWn@ۘ#>n@ c/n@2n@#Hn@dUbn@qn@@]in@z o޸Mn@?X&n@f6m@aɱm@IH{֠zm@`R*[m@eFVm@)zs[m@H Um@8wEFEm@7XBm@HSSm@)2vm@},hm@Nm@m~7@n@rjr4n@)&"n@SiZ n@5N7m@m@P^m@LZm@Fm@ R]m@( Km@!ji Nm@)R^m@p'CAsm@$HL+m@јVʴm@*m@Mp9m@Qu>ln@Jn@Uln@j9cn@L}s n@+n@F5n@ 8n@xGq0n@?7n@S*; n@o hwm@SC[m@0m@jg3m@FNm@T%.tm@|9Ym@|0@5m@m@Xm@ejwm@,m@)rTm@8aom@xm@m@Em@Gdm@ ɑom@tTm@]m@󨆻m@”@m@9m@Ѡwz+m@2g}m@@,Xm@j!,m@=.l@{'Sl@*7'l@!$ԉl@l4dl@$4gl@ʓBl@%l@aʎl@~ (l@l@Ҙ9~l@nG}l@"l@Ka?l@D`cl@Ul@!POEl@il@l@nvgm@Pae1m@hchm@ ´m@>D$m@ޥn@|0n@lǀVn@תkn@9U[hn@`Qn@Aa`u1n@nqSn@Qm@Cg3m@om@ٝ?%Bfm@NF=m@*5,/m@ Em@heH)m@+>m@9߹ n@B?nQ#n@D+eTn@(Dn@ xm@ޓ|m@j1^vm@%<m@evm@^Nmm@ګo/Pam@6lm@,jm@|$┬m@Y[m@V!A>m@Rm@l 0m@Hđm@ꯥm@Rסm@7m@b\n@r&Wn@PYsn@nrn@MBcwn@/ xn@5iAsn@{2m@/ 0m@z%m@J!m@+s,m@.,p2Lm@l#6lm@&Xqhvm@7mm@|xkm@ۧY}m@DGm@O1MD0m@\$m@1d n@%n@:2:n@4In@߿7Un@6Qn@9n@03@$n@;.yn@m@좕m@IΓm@A)xm@_gvm@)-&m@m@Em@bm@Κ'.m@(,m@{Zm@bm@)n@)i n@s8n@r%n@|Gn@cX8n@3n@G4]?n@TTn@Kjn@̘ί|n@D؁n@Jn@Tٙn@xvn@ n@n@n@gQPn@Ko@WJn@ٞn@.dn@$_?n@rHdAn@X"P8n@Ulcn@p(n@Knn@2o@ӹo@gs/o@M5o@>5o@7(9o@lϻFo@Y͒Wo@6Uao@Ӕbo@.HS?^o@Lt_o@)#dn@+Z;Un@x ֒7Nn@ᨔRLn@Mn@#Kn@K[\Hn@3vAn@:X~:n@m@] cm@LRExm@g祴Tm@lBm@0 7m@'m@am@,m@tlm@+l@w"l@E?m@Y5(m@t$%+m@O"m@Lg47m@}yVm@:4m@>&&Mm@xm@ n@3=n@S]en@ȃ*ňn@P.蒖n@1ʉn@r;btn@{lD3Yn@/?/n@]ֵbm@g/m@E0m@wm@vm@YO,m@Om@3]-;m@Tj_m@=ym@2wm@ m@dLfm@]Km@>4n@n@%p1n@m1,oCn@YHn@|럭Cn@8.L5n@a>Hn@*h(m@[(m@jͺR(m@&LYm@8Km@Cm@ǂCOm@NIm@+m@jum@JgVm@Nm@ڜu>m@aUl@mSTl@JJVl@ҞiYl@Wl@0xPl@unJl@ڰsLl@FESl@9ːo\l@el@ oml@ZAvl@.=l@_{l@` l@˂%l@Q5- m@upn2m@&Qm@)tTnm@aY[m@m@,7m@`֘'n@Kn@GOmn@Rn@a6$Nsn@:oHn@H3n@y*m@rcajm@Aj@m@6O:m@e/Rm@7`um@(7wm@"DVm@(om@ڧum@n@d+m@s:=m@t m@Gm@.g>m@H`z[͇m@wm@m@qNm@Qm@{]t.m@l #m@=Sm@#ةm@6,m@qm@֤m@um@ FZm@!!n@ $R5n@vOo@.~ o@\3o@'n@pIn@?n@aaǰn@Β:n@lnn@;n@:EHn@xn@bӓn@9n@~M5^vn@(8dn@2z@XWn@pNn@>9ϑJn@*(!oCn@@w@! n@,+6n@Q)n@g!o#n@,k:@,n@3=n@_uCn@d93)n@t^xm@mԆm@Dʷym@ #Om@1 7m@X[(m@`ϲm@՛H. m@Bm@r5Bl@r Țl@qo毉l@`쭓l@d2l@g=.l@2:K6l@l@:2m@:^m@I׭m@_Im@5!n@rw:Pn@"n@o:dn@TBKn@^l73n@W~^n@7}n@@ .On@I*tn@ sm@Dm@*m@ 8l@Xܸ7l@I@2L:l@>l@Tu@l@]YAl@Bl@m>ECl@xIDl@ { Gl@PyKl@6)Sl@$(`l@Qxl@4.l@넵l@.P4sl@ m@OWY00m@rQm@р"3vm@_:m@JPm@k? n@+R7n@PqCfn@[n@.WГn@0pn@@Ŀ",n@u2m@1؏m@XbVgm@bSm@Tm@ی^m@^tum@vm@ մm@ m@m3m@W4Km@Y5m@cgOm@+m@h- ھm@{#m@xJm@7`m@+Ǎm@xm@i,m3n@/n@cW;n@'XKn@NɤXn@\bn@8Xsn@ jn@JƁxn@f3n@-Pn@I^Vn@m7{Po@]1a[o@\|Qoo@B o@ro@t|o@\o@͈o@9줿o@:#ᯨo@wo@5o@Zo@NJ[o@o@xo@, /l@t!:/l@g3p3l@6ɨQ3l@òN,l@#%l@S J%l@ 1l@I@l@~ZKl@ DOl@Ll@{b=QFl@ @l@_>l@R2Al@'Kl@rpal@ӗl@"l@1l@J_l@X m@)B@m@Cȕdhm@T m@mm@UKm@)"n@~uRn@5xn@Vn@-kn@W6n@u-CL!m@ez(m@Rςm@ awm@odm@~*ZVm@[m@mm@f@m@Y8ܧm@Nm@ pĹ*m@kƵm@6Gm@Pm@qUm@C=m@ m@-im@L7 sm@*om@]QPm@L^m@ /m@)6m@mPm@]>ؾm@B<,tm@sxm@j"n@X'n@~i `n@7n@`En@n@, o@ >o@ˡn@ ^βo@bdn@n@¬*n@n@ps{n@D$\n@rt=n@R)n@4@>&n@Nw2n@E)Bn@.Mn@28Sn@{yW,v\n@#in@ '1qn@ǩBon@X]un@1Zn@QFn@gdn@mn@,sn@MIn@vd8| n@N;n@ m@ ; n@&H&n@\En@6icn@un@Kvn@.n@(.n@Iuټn@"įn@;g"n@ 4n@#ֆen@CJ&n@8>)n@Yn@6n@ޒn@sln@RNn@#n@كn@ש!o@\]Do@(NNo@vGo@mAo@FDo@4Ko@" :No@:No@ޚSKRo@2(\o@&(-mo@ǸQo@SƏo@ yo@Fb̟o@5lo@+6No@ǖ-o@~to@aq4o@x\o@4o@[ o@Y]Do@f<^o@ko o@Po@ Ljo@pb%o@Ċ o@o@@zo@o@9Jo@\3o@Fϫqo@YRo@O 9o@R])o@oz"o@ٍ/o@"o@|OЕ o@3Bٴn@й"n@qn@]tn@j#n@ 'Ln@+$'n@ ^n@?n@ |n@ޢn@-=n@AVdn@&{n@Pl~n@bqn@%z•n@wn@hcn@( y.n@Xnn@"qM^n@ 2Rn@lҥHn@-4q n@Qmn@#Lzn@9{n@{uMm@BȩȾm@Ķ-m@VTVbm@On m@Zm@am@Km@ǵ!/m@ m@0 㾼cm@g?9m@Mdm@7l@K}l@Vbl@gl@ռl@ڑZ/l@$!Fl@:pʁl@ngkl@fUl@iaBl@4l@NԀ+l@ 'l@h)l@ ) /l@s1l@}+l@~wK!l@OHPl@ȕP)l@iպAl@()Wl@LVal@I`l@Tv\l@6cWl@v(Rl@؀Nl@2aUKPl@U]J]l@+!Oxl@Y:M@l@1bоl@?l@O-m@v*m@ \Vm@d3m@4G'm@ʪuum@uhn@on"p=n@,\}Vn@XwUn@x1PDn@CYvn@tq[n@8n@n@ n@阏|n@D En@5H~n@7)jn@K;n@o@8+o@診Io@pd%Ro@qPOo@ʟ6No@xWQo@sjQo@$UE,Mo@0uLo@QĎTo@Q#yeo@; xo@ݕ o@ۑ o@ko@oNH o@Ao@:ADo@ч8o@o@|J8o@>|o@%QSo@o@>yo@5z o@qo@Km1o@noo@b4o@H)Fo@Uo@T4o@?$vo@h/Xpo@vo@!@Xo@+Hơ?o@ ű.o@Ή: $o@H!o@^o@o@LZ)o@_ o@j=n@NA{n@HKn@lŞn@Ơ^Fn@1 n@n@# n@5dn@zbn@H `Fn@)+fsn@?nn@I??vn@Yn@6~n@ӌn@>Ftn@v n@xfnn@-Xn@_X&WGn@=n@76n@n@ gn@En@hez1"n@m@5)Rrm@2\jm@m@(I[m@(m@-ĺm@k'n@yEn@+ >m@sQQm@Xߛmm@ظm@~m@$odm@* m@eQm@&dn@n@n@ an@E Vx%n@unMun@54yn@ Tm@yV1Am@h**m@IQאm@jG_m@3Pmm@:7`m@w(8ym@` +Wm@R (m@mBl@s~:l@ l@i8l@QҿXl@@nXl@)ƙl@JyN~l@ILl@al@g`Dsl@ldl@P?Sl@!SCl@+x9l@hJ4l@->3l@|֋94l@x&6l@N3l@f;+l@w'G%l@W-,l@M^>l@xGFfTl@=dl@GNml@@m\tl@zl@3Ht8-zl@bul@ *sl@ݛxl@/@Fl@6&KRl@G kEl@^l@7zl@[+m@4,=m@GKgqm@9m@t#ͥm@n@Q%n@ Y/n@V`!n@%q n@1Sm@qm@3m@H\Pem@avγm@c'n@m@@0 m@ÁIm@6m@}>m@(m@jڼetm@Ybm@cm@OJ.{om@ sm@} Zm@I,m@`3ʪIm@9l@) l@yͤm@33kLmm@ām@Gcn@k@=5>n@ %}5n@ř,n@q5n@Vn@w n@EpFͤn@\]|n@״Vn@>Q[d3n@j|)n@Ipbm@Wm@ٍm@.m@Jp;m@.oUm@ m@qzn@ n@㽑Xm@̆m@1.Im@OJvm@MNvm@<2m@e|m@, m@wm@N_e5m@Vjgm@ :;`n@U3n@p7n@n$n@?rJn@,%}m@gpm@ |m@}Wcgm@;ρ I]m@``bVm@,x-Fm@O蹕S#m@m@}>ɺm@\ m@4ڸHm@r!Hmm@[ѓ11Wm@ @m@{d-m@֪Q/m@4N9m@i^=m@KDm@Rtam@/m@aq m@o(Ym@'fsm@_raFm@ۤFm@<zm@d?m@ m@IZ m@mJ m@Ƚm@+#Ntm@0ץ=m@VVw"n@ uPn@Swn@]"n@zn@9?n@]zn@5kn@n@chR(zn@uyedn@90Z%Pn@|lE5n@fPn@%О4n@j n@ˮLn@Ac%n@ܿ2n@;0JEn@qahn@E$n@nߔn@5𗐾n@'Zn@IpTsn@srn@n@]pn@Xn@6n@yn@1mn@m̋n@/Frpn@[-in@Li(Vtn@@|n@}-xn@T jn@& x_n@j^n@zkn@$rCHn@ի۰n@ |n@un@4wn@\XH6n@^Un@lK6n@ []n@67y4n@Հn@I]n@Ұb& n@2N(n@ѷzYKn@{]dn@+wn@ijn@FR n@k_ln@Vnhn@Qun@E_Qn@3%ۢn@a㷽n@W90n@#n@Ҿn@ jn@SIn@o@ v;o@T%Ro@r o@ҍN o@U2o@\=o@pyDo@Q/Oo@m*@\o@Bao@Vo@. xDo@\Lp?o@ʨ=pLo@{Ր`o@&`ko@Eno@2Aro@~~2 }o@#tCo@*$Rn@lyn@̄.=Gn@Jn@)Qn@4Uxn@n~Zn@ Hnn@~rdn@hn@h s {n@Wόn n@֘n@[n@Gn@Pqnn@غD[n@tS:*En@/6S:n@P1H#Bn@)MQn@c"dVn@)En@FVe,n@\9fn@qn@$x]'n@Bh9n@DGn@B`YbGn@ubz=5n@k n@m@m0jm@' =Xm@ <Um@lCm@|FŶm@Om@Im@u Φm@ɲm@=Пm@F"qm@B@m@@m@W%m@@O]m@[m@m@j/3n@y:Tyn@l꿚n@Dam@Km@;?jm@~um@B0hm@%3m@1on@%zn@lm@,m@,Qm@ҍgm@LP*hkm@e`RCm@em@۶ޢϱm@qpm@ m@[3=m@w#n@)=n@͊hl@UU^l@l0=dGml@۾Tl@yYdϢl@Wl@:Ȃ"l@G?8l@SÃl@3hl@GAl@~ytl@C>l@"(l@łRIm@bO6*m@R1Qm@fym@nˣm@m@ m@,m@?m@p&ӌHm@1"Vm@XxyԷm@U!m@c22m@.ʯm@whڟm@/}m@rm@,Tm@_w1m@W!m@!m@L{m m@]V"m@*8m@:`m@?Jm@|m@ sdm@|"Dm@|ĦIm@Y|m@ V5m@m@}&"2n@ [Xm@1um@dK%m@w[m@wTn@=sIn@jIwn@.g9ӷn@/n@f.Zbn@Zn@Krxn@)[n@o/!0Nn@%!uFn@ ~8n@Uǿn@!N"Cn@SP%9m@qFm@$\h@n@F@7!n@./n@En@)edn@iʠ= n@WlЏn@Y.mn@u\;n@2p~n@/Jn@\n@H5ʏn@4Nn@MLn@In@Í\n@7vkn@^[n@V!mn@xQJIn@sD)n@>n@.Sn@M(vn@,n8sn@Qwn@~׻n@thn@Dn@^.cn@a7Kqn@e^5n@U8n@LYˈn@gZn@Hx1n@|Vn@8(-n@gk n@C;WZ6n@Q.XPn@0%xLan@`kln@s.q1|n@֏n@~z@n@6_n@=g_n@Yn@Nn@mnTn@Fn@ԓn@;Gn@DAco@yo@xho@h $o@Z;'T&o@4<-o@C^d7o@):o@q8o@;o@Jo@S[o@K^o@Qo@Bm@o@z=o@FߝIo@ ]|AXo@}W]o@`,vZo@N[o@ijo@p9'o@6]o@W8o@[]wo@lXo@2o@ko@4My3o@F$&o@<Ro@;\6 o@NHo@Fj>n@n@veHn@n@Jan@-?n@bDTn@|ELn@gn@l Wn@)(n@t7n@lVhn@H\n@zhC`n@m̚zsn@q*n@72n@1(jȌn@l}n@oMjn@\޷Un@DײCn@eBn@x(gVn@٧pn@t zn@ofn@e<"Bn@{h!n@sn@pf n@Bn@j˝bn@ h_em@D~r8m@$҈m@UQbl@3l@E?Ul@_^*m@/~7m@$˺ Om@`m@Gm@hm@A n@1ijn@k|n@>n@;*ۡn@-k7Wn@ w0n@ 5+9n@rOn@ST/Un@ n@o@[3(o@Ao@B8\n@^n@K'iʼnn@FMan@o@:H,_Eo@kQGo@ 榸 Io@A;o3Ho@ݐCAo@7S19o@9wo@*zBo@"q!n@CSn@F[n@ϳn@pIn@WNtbn@Wn@p6tHn@PUn@Q^n@ 7n@*n@@ #n@pLWHn@O;Yyn@T=Gn@df肔n@Դ~n@lɹMhn@zTn@ Gn@d>";n@Z Z`4n@vԩ(/n@u`ܶ%n@S|Z n@~5O(n@7]WA3n@uda.n@vn@P^Com@qe`m@[&ӝym@$}R4m@w m@z1tSMm@V:Ekm@Om@d;Fn@F/b~n@uTn@Ke^n@~Ѭn@ݤn@ژe|n@W,Tn@1n@sKKn@PC?n@-o޶ n@MNzm@l* m@*$0m@H:m@vn@o#5n@Z +Ǫ0n@ n@m@c zm@|k)Zm@BВm@[\}m@ܟ8wm@VB>m@!sm@TLvm@Ѷ(m@8j"n@q&n@arYn@e:m@Rm@Fdom@+Cm@k@m@Al@!l@6l@J8Ol@;UBl@EGl@>LOvl@ɣ9Zl@ {UCl@ٗ%5l@4#j>3l@Ba\$:l@EJAl@;%Nl@KsY dl@xyl@u!1l@Ոl@ڂCl@<.l@\K1rl@L:_l@t8Sl@2v Rl@{yg[l@yil@Hwl@t 0~l@ө?l@DBTjm m@t"m@=1m@ܯm@$/82m@ "m@SCm@1zm@q):n@3+n@r¸Kn@ޘon@amdn@.h+ـn@^"dn@c J gn@&}YLNn@w9n@,Qk+n@~t[#n@w&n@M[hߨ9n@1kKn@\1qGn@w[?/n@~"n@3v8n@Edn@van@:n@Cn@ar[n@7:]n@5hn@ Hڿn@Bn@Rxo@Ԛ%oSDo@;.H/Ao@iުo@ n@_n@s1˗n@Hw`mn@*}@n@z>!n@zn@Y$n@:n@μPn@:DQn@lKn@!+Qn@l`n@0|܊kn@\kn@qSM}hn@!&dun@V<n@Rזn@snn@ؒVn@do@])"o@WʙAo@Wo@TzG_o@¶ak]o@q|Wo@I\'Oo@8c>Do@ua9o@w /o@Turo@Sw{n@s'kn@"ZՔn@Ƶyn@n@@՟Dn@xrn@ n@Fzn@9pn@c`n@zj ƷXn@NqXn@(-[n@"]n@bn@`h8hn@jin@tڇbn@Qn@(Fn@6$JSn@>tn@ʓ4n@s n@f{n@i8m@Xjm@ys n@*_n8n@;'ALn@@OHn@HQJw=n@1',n@-in@iأm@6⤑m@~g[vjm@bm@xiPwm@|Ifm@X^{m@2P01m@.'#m@Qwm@gX{m@Pqm@gIwm@PmfRm@"/m@v6m@P'l@yAol@gl@mQl@LPםl@ ʁl@Kxi:cl@ aAl@[0$l@Lml@S,l@٬n %l@323l@vFl@4 _l@@ xl@ JLJl@lol@G3l@Zul@Ȳ14~l@5] ql@>Ǧil@V a7zil@#nl@Ozhul@.MB>l@mt^ljl@+.%wl@Y26%l@1`t@l@('l@l@ʧl@XEol@{9٠l@pСl@]hl@lt l@1sl@SD m@[% m@D .m@#23m@?[.m@] m@'Fm@0iVm@l"m@5˱m@55m@h3F*m@;궪Jm@zoW7km@5ِm@p m@KRm@51 vm@Nxm@[PѼm@n(3m@&Gm@ m@__m@AUn@s n@QDn@oDdn@VÇfn@b>Dn@4n@sm@O2m@q={%m@oSفm@?m@ʐm@}/ m@-Zm@"hm@Ƹn@^Ǡ=n@gBwmn@qؘn@ұ C4n@Fn@n@?Ijn@IqBn@M#n@)Dk n@7cn@m@r_@ n@ Ӏn@9pn@|\ n@ŗn@6/n@#bݑVn@j:}tn@ghn@en@ n@φn@!n@!n@9a_ȵn@] Co@ io@q/ DTo@Th_Q"o@d=n@n@A?n@qn@dm@n@-$n@8&n@f8n@eOOn@$]n@4Un@?>XLn@RM+Qn@ ]n@Sin@mrn@ ,+}n@Ln@V"un@2n@:n@1n@b`o@F!'o@͔nIo@G_o@obo@:Xo@"5Jo@vp3?o@ZR`7o@zy7o@WOAo@PjMo@Y6Ro@q ,No@f")Fo@3(]$Ao@#)Eo@Eh~Oo@V ]Vo@/S9Vo@IVo@,aԠ\o@lo@9$9o@!o@[Yo@ o@24o@ iwo@8o@X>o@*o@ o@,o@(Ho@<'~Co@j`*bo@ϾFo@Je1o@M@o@l o@(i o@lfTo@gH*$o@^3jc.o@ٺ(o@BSo@߇ n@en@ jn@Պ6n@瓉n@Ƭpn@ȳ(n@,n@ n@e%o@~@n@霊n@0n@.1$鮺n@TBn@:ĉn@|xn@ڲjn@J8G#bn@:,8GZn@RPn@i[fEn@IvDn@!(Pn@ܐan@Rcn@.H"In@{Z+n@-:,n@lFn@$܆an@n\ Eqn@"&ln@&sXn@sKDn@ ,=n@HMn@N6un@c[`n@ܹ n@"n@l4n@An@,n@QW@?qn@܂n@ig[n@ނ'" Ln@S Un@`gn@P qn@>xXgn@ov]Sn@>n@3qn@+m@wm@o@m@FBm@ڤZxm@5m@hn@>in@nL0n@8Ln@Rn@sn@ wn@9n@x Wrn@E7an@sK]Ln@0n@IMZn@]l@@l@`Ul@e\l@Wrl@J#!=l@uNhl@f~%ֻl@sPfl@D⦳l@Zbl@xl@~ l@6a l@s@l@sM=l@%b9l@ l@H%l@~l@>l@|pl@pf m@ǔc,m@mJm@fm@1B m@m@(}= m@/kl@"UB l@=L2fl@pl@f0xm@Sץ m@WKJr@m@Y-fm@ogem@kTm@LKDm@=En@2m*n@vD}m@um@|ǽm@km@}m@5u@m@Gl@ul@&l@Sl@nl@twnl@2hl@ al@ĘUm@h7m@`Pm@l6am@vzm@ϻm@l um@;m@63 fm@ tn@!Dn@B5ߥn@7n@1RMn@۠Fn@ZC~n@eKm@zcEm@뻩m@l{m@VWm@hm@Oթm@łm@ڻm@B]m@ ktTn@+In@`Exn@n@in@9@An@H{n@1qgn@ܥ!3n@\z n@m@0 -m@&m@m@]Vm@GNm@m@\K]n@Sg5n@y=Ln@,Ƣ_n@ 4YӅpn@9l1sn@qljn@{Z9`n@Adn@w^?n@DOYn@D>a@o@feo@SzGo@ğ,1o@#Azn@0Cn@ I'n@ys=sn@;XHn@;n@[i.Ln@%~;an@pn@++$tn@$pgn@F _n@)q dn@"Vnn@ Fi|n@\n@&Ӟn@47n@$n@;n@n@\)ƳOo@b[o@u^o@ao@Ƀ+jo@nمuo@e澀o@S_o@F*Eto@4 vo@tOI0o@Lo@-EϚo@dBso@A%o@ǵo@Wлo@o@G Ѣo@pzbo@׮1Bo@nP'o@ o@3ڹGn@cyn@gjo@c o@N-o@+o@d=gDqo@[2SJn@*n@~zfn@՚n@C2gn@Wn@a詣n@t5Xn@A o@C)U o@h\6sn@ @0n@]"5n@68n@n@Vn@ZoLxn@VnՑon@,mn@W8fgn@Xn@"hCn@首D8n@ȡAn@'hNUn@Wn@r4n@r n@&p.n@)y n@Z$n@MAn@ #Un@jpSn@,_Hn@o}*Kn@?$Kdn@WXݏn@A׾n@}("n@l>n@oӄn@]n@6UZn@+,7n@ms7n@p!#Rn@v1n@8*-n@_#&=n@+۫pMn@[ INn@Ot:[ Dn@5拃:n@|Q"n@|ʈdm@]m@ܹTlm@HMam@ެm@S(m@E n@Gxn@*n@\o@/ o@n@+in@Ran@$#n@I}zn@`\n@hϡ;n@!Vn@p n@in@l@l@(m@"̆m@3q*4m@=^[m@MBm@`ym@p-xxm@,|n@?R:1n@ MwTm@$/Om@*m@f羒.}m@}O{Gm@ m@Ml@5g{l@}l@\ l@d&l@lLP`l@/ԓl@em@sO7+m@3xIm@^J]m@6erm@"%om@6m@n@~n@+)n@ݝcn@ѽB$n@g5n@d9n@_ n@m@VO5m@oim@Pdk@m@|Am@\x;Gm@m|S~m@޺m@ũm@ m@f_m@2D n@Pn@pn@\tn@+|,n@@POn@]2n@@'Yn@>; !n@\Cm@Ƃm@sm@m@Ȼm@m@lm@Nm@3"n@,Tj@ozio@7i+6Do@?Y$o@ o@Hn@nebn@D ! o@ep$o@t-d5o@2o@e5o@ۇn@8n@*n@,zbon@N)n@&n@9Ѱn@&n@{1o@$Z,o@r>n@M4n@ 5n@ӎn@uHGn@j@_%|n@~~dmn@ab<(in@8Crn@L00vuyn@-Qqn@Y/Zn@Dn@d?n@ZKcEn@oo?n@1n@,/m@)9m@em@kXm@=tn@P*1n@25}n@6CKn@0}kn@.n@n@͙n@zfn@Lj5n@Dd=n@3efn@đn@>R@vn@#4͞4n@@-9n@C3n@O-n@sUm@ N"m@ǎqm@ Şm@Q m@\bk1n@V8n@4)h!n@m¤&o@? lU9o@[!o@ˆv n@eؖ2n@ Tn@WTۈn@Yƀ^Bfn@[i>n@r n@ n@. >n@)m@Hm@hqZm@sz!Pm@lnm@#2|m@ZMj m@^Am@bm@<üm@ѻ[Hm@ĝvm@Jm@|#Ym@ l@++ l@l@Xql@`-tcl@7l@ξl@'ߪl@|. }m@$` Cm@X _m@ ixm@Gm@Am@C-OBn@#i+n@u`J:%n@ !n@# -n@r.x-7n@ID)n@.{n@dCAm@?wm@<im@4dm@^m@&mpm@&wm@Bqm@5m@Nm@wmLn@496(;n@uu]n@Ϗ@n@Zn@1fn@>Hn@ѥ Non@Ϡ%Jʐm@]ulm@$7m0m@퓠Tm@}aKm@O_ +'n@ AcCn@M,Vn@:ln@DYQun@Dan@=82Vn@n@ n@l Ln@n@ 'n@n@Svmn@ֹ˜[n@#g]n@FCvrn@Ȩn@E1un@˨n@dyen@AC~Ln@ ;n@Hۡs(n@m3n@AVm@$|m@S*~km@S ,m@N'm@x5K;Vn@mN^U1n@?Vl=;n@DSCn@i7]n@յ&n@,≭n@i@n@Hon@V@Ln@*zҍn@qn@4GSfn@ן GMjn@lXNn@ 3n@Gb(m@֢yn@n@J9w#n@>V,n@˗>O7n@&NS>n@k_D0n@#A. n@x!m@Ehm@>+Qm@"m@Bw8n@KyKn@ˑb]n@ D8o@\lNZo@ДLSJo@v[#o@`n@a"!n@! Ün@# gn@d /8n@n@D m@-m@J1m@Udm@dm@ZFMm@>(Km@ D8m@Fm@6tm@./Am@6"<(m@'m@1m@<:m@hys>m@.UԘHm@_m@ 7xm@׿m@+7n-m@=3vm@߂T]Tm@u'm@ ,Szm@Uyl@`w kl@esѻl@?ʌl@ t̳ȫl@rl@y[&l@taol@Cl@}l@hu-Hl@7Fl@tl@"-dl@xal@l@XڀTl@-]Il@.l@M[l@bf&m@N9m@V:m@Y<:^m@ JT~m@Mim@)ːm@i[m@.*m@ b̭m@u䟧m@=4m@߰tm@/m@pm@C>Km@L+m@Z_tm@u Um@!1-,m@m@IGl@STl@D~l@L#l@Sl@l@ +l@Al@e# m@ ^1n@Dn@=Yޱn@żn@|in@kAn@9=n@fCn@z m@ fMm@?\km@J8Am@Lz7I m@8*n@]{&?n@+AFn@gF+YFn@SVk[n@.Vn@|h\n@Hn@/$n@f$tn@lPXn@։m?n@S@n@(5bn@tj4m@˒"8m@ZAE^Fm@E^m@i(vm@z m@z,|m@|ASKhm@ۮvXDm@I2h%m@OD/l@_t{l@il@X5l@\ۧ_=l@wl@PЃql@eJ%yl@lI'Y9l@~Ͼl@-'ݳl@R/l@%jl@jE.%l@ol@dO3[l@gvm@l@rB*:l@xl@؍m@D8 m@ FYa5m@VhKSm@•Z'sm@] m@m@dm@7Pm@m@۞Fm@DIjm@Bm@m@TФm@_6m@fHm@j(Ƙm@nqQm@em@+{"'n@쳍n@uO`m@rm@Yۆm@jm@ۑ]m@F!Lm@>WAm@dw/Pm@m@>?cm@,n@l+n@&PAn@\{{Mn@GJQn@XRfRn@+In@B.n@r:` n@$T܁m@rDm@cWm@ng sm@wn"+iZm@8>XVm@v/am@MIwm@NWWm@m@db}n@7n@:bn@bn@C"n@Q~{m@X%n@B{Zn@0vtn@?n@/n@'(n@iCUn@mn@ITFlln@3YDn@y1n@Cn@vtan@ˑmon@Acin@|tan@n%mn@2Ŏn@0wn@o5n@ n@n@^n@h#n@X,n@Rjn@n@ k~n@C5n@Sn@78Nn@7vfn@exfn@$nn@E`o@N( o@7 S9o@8;7V{o@Xo@'^o@ZDn@vn@3n@8mn@"\ƺn@F#o@K:,o@4^Qo@EyGeo@ڃLeo@>-R=]o@n=EUo@0#So@`{S^o@ [to@NʸĘo@-',6o@p@Дo@|̘ro@mJto@_x`zo@(9o@so@]]{o@hyqo@cwɅho@ѷR`o@>LZo@ȐM"Fo@r~g7o@1Ӫ,o@ɆS'o@?,!"o@ao@"\vo@Rjo@Wo@Z"o@RAیo@ -o@1 o@Jn@p$'rn@%n@k1#ģn@%2n@nn@%n@Wyn@;lan@ȚoW Sn@PYn@s6QaPrn@]un@S/Xn@jn@%̃Pn@@Bn@GNVn@S I*n@P$ n@m@:,m@)>m@OqA(m@QZ?Sn@ Uc9n@U3Wn@*0Tn@;TKn@,KiXn@7qwn@lTn@ʇn@Twgn@\vTGn@lCm,)n@Ftn@p}qn@Bn@Gxn@g$qn@;@yx\n@XЅVln@!@Mn@(Uun@m]Nn@. n@eMqm@ĸm@\&m@:Np^m@NDm@8m@xZm@ dn@sΖc^n@챸en@goYo@KEo@]Bo@c`o@rn@.n@Gn@”lsn@T]ZHn@$n@&ҩvm@h9jm@phdm@(N&m@,tm@(43"m@=$m@3S\m@rNm@ܡƅm@|*Xem@}=5Hm@ 2m@)"(m@$Ԥ*m@6m@}Jm@EU'am@Nc¿pm@sm@Ԩ'-km@mv;Wm@"*j8m@Mm@zӽl@@,l@(vl@El@:l@b[eMl@2]l@IMl@%Y8Ưl@s::l@[Il@?l@0W8l@bym@q"2m@,!m@J3 ڬm@V3eQm@z#m@NȃMxm@{zwKm@F"ˁ$m@afUQm@`W8m@2:m@Fs m@h^&m@֯ڜm@#m@ m@@:>Ym@iZ0m@~m@' 3m@"8m@$m@bUIl@ד'zl@ cl@ fl@$m@](m@s[;m@~xCT@m@++jlf?m@ڤhnm@Kn@*V n@fm@j|O`m@%nKm@>{Dm@3Im@۞d[m@{m@pEgvm@Vm@,n!n@rLOn@)&;&mn@^ɓ]nn@_Hn@)=vn@YJ Nm@smm@M"n@*q 'n@(n@Xy3o@[n@UUn@fn@nwn@Vtn@ٵn@%\n@ `n@wV@tn@VUn@W#\Ǔn@n@L)in@n@ p^n@|S.@Io@9̼F7Co@yZo@w ^o@[9Vo@BY{eJo@J(RBo@Eo@ɿSo@{TXeo@֒>ro@B얆to@#=bo@[ݪeo@WslJio@_^'mo@Choo@|oo@\3v0oo@lr oo@|lo@ˉdgo@FH^o@ Lo@3"m6o@ 'o@X|#o@K=!o@5Vsy!o@F9?%o@&,o@LQ6o@@o@+Do@w0f:o@ٍ="o@"ƖIho@Nn@yn@hٜn@ᣄn@D|=n@T0n@n@xxn@kn@Vjn@@c\tn@]zn@n@_en@Sen@'n@@\qn@RRBn@[TRuV&n@An@ނn@>]%` n@QxZ7n@CnH24n@?_n@S|qwn@#IC5fn@&Cn@gm4n@ Fn@o^n@bzVn@ARzC5n@٥n@]Km@}-;*m@X4Ym@@F n@ȒڦOn@Upn@9vn@巐_n@n@rC"dn@q]n@2ƺnm@vٸm@3LRm@ZUԤm@5l髰m@G$Lm@">\ƪm@RhԽm@/m@?n@ an@R n@6z%~ o@[`V2o@6on@#n@L9n@|eyn@F|vn@q#\zVn@|aM0n@hn@+@\m@>l@m@aH m@xm@^n{5~m@Vgtm@cm@m@am@6&Dcm@Am@nd'm@%Zr m@ "lm@MZ0/m@r_Dm@.UVm@s_m@?44\m@RGL Qm@>UGoAm@m:(m@_bm@1l@*㆖ l@Tl@8Zetl@U~-ol@ Nyl@QnNl@]+l@ü&۟l@m}dl@w-9l@LcXl@sl@3hl@ m@gLm@8*m@Ym@:p(8m@Y4m@w۟!m@ .m@I>:m@ a}6[Km@&Wqbm@rBm@|_8m@զ'-m@Pe7m@csm@|٩m@$wm@a8m@#ψ#ųm@xm@J{bm@DŽگm@+c㏯m@ӝcŧm@BTm@\2gm@C?m@o$m@n*m@5A9m@7m@R$m@= R*m@s5$m@ͅ m@m@Wc. m@Mnm@_%m@Fr$m@d m@#Ng m@@l@ڽ;l@Ul@r09l@dsl@ll@&wt m@)mm@жSR~m@-Wm@1Ym@HQm@8l@b^^Ml@l@b32l@5l@Nɘl@l1}l@vNl@sbm@ vZtFm@Jum@*Jm@@m@,~ m@*gXm@^m@! (m@֮m@m@em@юcHm@Ym@Kqm@չOm@3m@/m@403m@h]m@^6fSm@ GRܘm@1 >m@G$m@V"8m@ctm@6m@KNfam@z[O m@;Jm@?m@UFЀm@S{Eum@pfm@b-ITm@UCm@DT:m@9m@rpDm@vMobm@Gǒm@6m@~'n@S7-)n@h*q:n@{̔~ 1n@Cn@гVm@f_+2m@n@&"n@*&'n@8}!9n@稼n@#q³n@@\In@ n@in@iVn@/|n@k TƉn@eSϯn@f(Kn@ġn@En@s@on@n@n@#-n@-_n@| n@n@Xen@n@u||n@7n@Nv̦n@l n@k4<%o@ݽDo@{TSo@]3Qo@@&Co@ z2o@URa+o@B0o@o@*YWgHo@hY Ro@\zhUo@WTIo@n`-o@c/v o@da3n@4s n@>n@ۚdn@Ui%n@kn@TS0)Dn@7n@:/Ԑn@GyVn@P}n@!;"n@ n@ٹn@n@t#:n@ n@nZn@FAYHn@,lAn@ʼn@4n@TDnF/%n@=_)n@C!Mn@v'{n@`n@Mzn@l>n@OZ n@(O Un@FXn@R7n@Ym@Mm@:m@ ym@sEm@νLݟm@?= n@tN,yn@n@upn@W6n@jB}n@b!Lln@OTn@%k8n@G n@tIm@:m@F|ўm@mm@v&%sm@1esm@/ym@6{m@ȟ}4m@~Hm@zVm@6;Wm@la>Lm@Ll>m@'P8/m@{ "m@22l@&P6l@l@Brrl@)|hWl@\rTl@`l@zqql@l@'ʆl@$(l@#0l@ l@6/l@SDl@u(;W m@m m@`A m@m@ )m@<9N m@fJzm@8Xp"m@B5G,m@fH=m@_& '*Wm@]um@7Jm@MVm@>Tm@| n;m@Չ m@z%#бm@_Am@ .TBm@Onǟm@m@t+Sm@m@iNm@Hm@ e~m@ dm@YMm@4&8m@ӓ&(m@?MU5#m@6Qt'm@ENs+m@LcC!m@k2y` m@al@7/l@_`Am@Wi"m@I)m@H,m(m@(m@(l@kKl@wl@K^٤l@k&նl@oVl@G Ol@{Cl@*l@|Xl@E͕m@Szum@s>\l@Mbl@el@am@b@^m@b}Qm@lAm@t6m@GJp1m@'7m@_ޗn@dIn@J~n@ް¤un@krSqn@wrsn@GB8tn@Aۓ*rn@Nfpn@I'pn@ҋ^sn@k~n@dWn@R$qn@n@*en@BvLn@5n@n@(an@ n@jYn@Eden@>ln@In@4Ķn@n@ߕvs&n@2Çn@Da6o@+o@틂Do@pzYEo@!1o@~qo@aa\ o@rOOo@&L!o@*h!9o@p?ENo@"BOo@n)4 So@}㡏Oo@BIo@d*Ho@|NGeKo@;TIRo@/Yo@{d t[o@]׬sUo@%Ko@;B?o@ e1o@!\E+o@e0o@\.9o@)*d>o@J%yBo@HV~Go@DIo@Lo@7LrKo@[ n@b#.Vn@ީn@;Nn@g<n@Q MRn@n@om@o_Wm@؀fm@ dim@}!m@k#m@S좍m@" om@'jm@4m@W'm@R'n@=n@wmtn@ƶ)2|n@Ԏ׃tGn@H~/m@D[-٤m@;m@?5zzm@`m@P҆m@~rm@R!m@K۴m@Hen@?A1Pdn@ QȺn@In@՟ n@n@<4n@2=̀n@vyln@kZn@V1Gn@:F;04n@` n@}j Fn@CKm@{xgm@5"3m@m,\%m@!&m@s m@Gm@@|l@ l@ɢsl@Am@z+m@ *m@*,M-m@I4m@y l@Tt`l@G[l@0Ml@W /l@l@.7bl@8BCl@qIl@+7m@*m@V{ m@pgl@J|l@Mel@ l@nl@f(l@8X(Ol@Vul@a3m@vOm@ܯ΄m@&'m@8~txm@OFm@%Km@:!m@?X*3m@݈Ƥm@m@(H9m@9~3m@U\m@Igm@0ۋ}Em@a%m@!8m@|m@UPn@࠹ͶPn@t_SqYn@v,[n@DyP_n@yRln@c9Kn@n@* n@]`n@"Rgn@JS\n@Gn@bk݌pn@P`n@yn@POn@MЂn@=5p)&n@+n@wn@ /Bn@kn@=n@iS4n@55n@H7L{mon@⌊zn@Wn@ۈn@ʫDxn@ݲYn@±N^n@9n@{胴n@&Nn@O뉅n@Vn@%-n@]m@'m@m@X ̫m@Tx~m@n:zm@L=m@ъm@sm@r7m@A^뾰m@m@rwoCm@сMm@QZQm@zHFm@4l6m@ |2m@C Z@m@f.չVm@/sim@|K xm@' *jǂm@)sm@#RN rm@{i$_m@ !yIm@u&=y*m@dVvm@\Gl@g٧l@e{l@.^rzl@b6l@6Ԛl@D鰬l@RZl@<#l@[>l@axl@d;ļl@.^ m@g?m@]T#m@83!m@k<{m@ƿm@H&l@ctHl@Y5l@fg m@/c m@^>m@]m@pxm@rjSm@fm@/m@1n$m@nc-m@Үm@ m@j~m@gAjm@J3Xm@v$Km@Cm@`VFm@*wQm@شXm@yYWm@%h;Wm@[+Xm@/Lm@)TF4m@I^6m@x9Υm@Yb(m@Pm@ l@ /l@XAl@"l@ Jm@Pfm@wD)m@F/m@~a"m@X*. m@Nl@G9Ll@7Vl@pCl@)cl@Ll@ Xl@O3Qm@qw#m@ )(m@R.m@D m@!Zm@}HT m@Шm@ m@K\!P'l@Xl@v&m@"+P:m@Umdrm@MR&m@y ͚m@xO}֎m@ 6|m@Q_Aϒm@om@N)dm@۵ߏm@Gbm@saԞm@'Udm@km@ `jm@q-Fm@ h*m@.Zw(m@< a?m@ݪD_m@BZVym@d^ m@9aOqm@i3Xm@b\)>m@>E%m@Bjm@^\_m@m@&F1m@i&-GRm@6em@('gm@ Bvbm@*[m@ԄRTm@^Vm@#ȟ5mm@_m@ m@5]R+m@=}ʫm@0;bm@9Ghm@K9m@bT)m@PQr5?m@:[K{m@rm@*P2n@f9 n@D&n@n@xpn@e3n@dKn@B+jGn@ӂ:i^n@ #n@Rn@}n@/Uo@id+o@]M#o@:o@Wn@gG2n@jn@yn@ro@qd2M6o@HQo@/hTo@_[Ko@Jm9o@Z2&o@˃-o@"o@e̩*o@8L1,o@`)o@g(o@h'+)#o@X}o@g!o@ʀ$0o@ECo@)Ro@,[Uo@Gyn@ln@`Ȋyn@1wn@?iCɬn@ %WICn@_Mǝn@4}Yn@w'sn@\{?n@Un@5;|n@sn@t2~n@EuJ܏n@VMyn@_rWғn@H+n@LVjn@,-n@H=n@mIvn@XIn@+n@ rn@[_n@X+6n@K#]an@X"n@~ m@f67m@m@Ռm@ЃЗm@`x7m@0m@7,m@_$\9m@sm@|Wߺm@W(n@8wtsHn@oMn@Co6&n@Sm@rBm@LLm@ufom@G:m@=p0Km@noFRm@%Om@SG9m@|"pm@KX2m@Yom@Vk m@Ιw m@' 8l@ $l@ŭ0l@i'l@~m@m@U*%m@PN:1m@ 0m@() +m@Nm@3!®l@D**l@f[bl@Jl@F9Y9l@m@MQ6m@ͅdEm@kdCm@E2r4m@&m@I϶$m@lG,m@ql%X+m@Fftm@Ϝl@|2l@R0m@yhm@}m@#nm@2 m@ωm@7em@m@m@#~m@ ;om@AGm@;[@m@ځ,m@۵B~m@EX[m@ ].=m@5J5m@#Em@j;İ_m@oHsm@4qqbtm@["b_m@n=m@xm@}sm@Cl@l@:Dl@]*5 m@_c5Pm@ NDm@t/m@0It"xm@4)e#m@wJrm@W 78Fm@i~-m@f6P5m@E(qUm@@wڗm@7\Y n@i n@n@ n@Xn@Xen@{'n@+Fn@(ԾYn@FR(n@m?n@֮Jn@~In@h+Ln@{Zn@|Ion@J{n@q[xn@Ajn@"CKNn@j'n@ sn@%o@ Sfho@L$Keo@aTo@E){;o@u==#o@Zo@Fo@)o@7Do@ޘ'o@1(?o@dWo@o@qo@W\C)o@}kr=o@'EMo@?So@>DPo@#BAo@6*o@ o@un@in@a @n@2}On@B"n@ j5n@qvn@2D'Un@܋uKn@un@n@}Syn@I~n@&n@8n@Ehn@Ԑ,n@z) n@A[͵n@(-ZSn@i1n@٧n@|>mdn@JXn@#kSn@n@@&*n@zeyn@)E o@;-o@2> o@n@`0n@J)Jn@Fk n@8f!m@sm@=W m@Կ>m@4]m@Vam@ŭm@N[m@?Gm@7m@ڐ%n@}xcn@༉jn@In@`n@Bdgm@m@Wtm@Usm@4m@J5m@>pm@-n@׌d#dg>m@Gƺm@tm@MYqm@:m@  )m@ 5m@!Kh?m@%;Hm@wDVm@H$jm@\m@U_m@4m@Qm@Jm@1Hm@ܔ`m@.b:/m@Y0l@[$l@Fel@l@ *_l@/i{8l@: l@p h l@6.hl@9Ӱl@_2Wl@u;vl@) 1l@ŪD m@{0m@"4=Lm@[Zm@\IVVm@m@Gm@}j;D m@8ji m@cm@׭6m@gi]m@40|6m@l !熖m@/m@>V^m@km@陌xm@4/Xqwm@x<(}m@4m@dHm@7y;*m@"2m@@l'nm@ܜV7m@ˀ9\m@C20ſ@m@8ʎ?5m@3m@N8m@C\Dm@tvMm@cDm@quV-m@K{m@nm@z!m@r$m@;st. m@"l@"?l@ٕl@wl@^'m@2m@4)m@ee12 =m@tFFm@:m@m@A[bNl@oKՙl@oI}l@?Cl@TX!m@$@m@ yYm@)x bm@]h4Vm@UC*Cm@:m@Fr>m@{/bAm@%n_0m@vnMm@fNm@:=z5m@p?,9hm@cm@Q|șm@ @ꝙm@2t<ǘm@{pm@^m@}(sm@W|ROtm@3pm@x$4ym@'lm@OX#m@Nj38xm@Q`m@O!Em@#Iď9m@mu;Em@.3[m@8]im@Q&cm@&Hm@ #m@Ỉl@ l@'q{rl@焁l@pl@G m@K\m@썄62m@'m@ׁûm@碢m@坱m@4Φ Tm@(m@h߶m@Wsm@H]m@ĕAm@k.?n@~Zn@ ;6`n@ЪdPn@$%k֠#7n@q0}o@^I%qo@kQ;o@X*Yo@y(}o@7so@\o@A@o@R5)o@nv,0o@%Jo@vzKo@=)o@@uo@ܲo@Bsio@1m@ Nh9m@}m@Yqm@tSm@c%im@-Ym@&L%m@c m@1mbn@)n@$wn@e)6jn@7 An@CUF,n@Ry-!&n@Un@AQ&m@E~m@s9Cm@Pm@~Ծ8m@ }v n@~?|Dn@|jn@|n@wkn@4In@gû*n@Dkn@x4m@i0m@HWu?m@>m@|;ͱm@Kvsm@;_I3m@[Q.m@Ll@l@?Sl@m2l@m@]{(m@dmqm>m@Mm@Wm@}e~cm@:twzvm@\qܢm@4>əm@\{Om@*—m@ٜZvm@q Tm@آm@**l@Iw؞l@Wvl@ Ibml@+~|l@ax=l@,3ttl@Kl@ ڹ&l@7g$l@޺l@YVwIl@ l@Jj+m@UAbfm@Vk`m@Em@瀤鋙m@̉ym@j[Um@we#=m@4m@,:m@UPm@pm@:Em@"Gm@cVm@" m@tm@/m@{m@Jrkm@SCՖm@Ԇm@=.Im@ZAFQm@R<*#m@m@RRSzm@tTm@aX7m@e'm@oHŊ$m@ҦY-m@ne;m@М%Am@}m,9m@ZP(m@!ܝjm@?,m@:m@m@FAm@իm@Ȯm-6m@Rkm@Z9Jm@\Lm@7EW#m@Ӂ=m@ $sYm@J؀gm@4gUm@v%m@џRl@f];ml@(s?l@cObm@y@Bm@wgm@M{(|m@dztm@ .S ^m@6Nm@XlKm@gboPm@|Lm@9m@?p{4m@'PLm@Aqm@֟ ߍm@dű|m@m@:;Y:Gm@ @m@y!Wm@tD0Im@1{m@Rqsm@6Z+vm@We%t{m@`ZH}m@wm@XCDgm@]Rm@?Em@7^@m@ZAm@zNm@zhm@[gm@; m@˔ùm@4ڭm@4ƯF=m@ahm@ptqtm@-OOm@w +9m@)ʮFm@hEjm@,mWm@;m@4 Gn@.Xڭn@4en@mn@n@]2@Tn@ ?;Bn@ U4([n@"Dn@iy‘n@t t}n@\n@RM?n@mmo4e n@*on@] dFn@fUn@8gsFn@n@Dt(o@|%X0o@1o@o@0$ho@JKklo@(Jm{_%o@1%=o@i[H\o@#uo@tS +o@wno@;l>,:Ro@-ٌ5o@xrX#o@do@ n!o@^B{o@e*o@+:n@>=n@- |^n@rn@o@K)o@|!o@t#o@)()o@z/o@!A-*o@3hQAo@ZI o@4(n@<[1n@Ln@O"Vn@,gGn@=5Jn@Ln@Ųn@5|j2 n@IQn@k"rn@Y@n@/rGn@pvqn@4|n@4Yn@>4n@̛^ n@qPn@n@[n@xKn-n@:#&n@,n@co@`0n@IIn@H/$n@|$|6$o@ab[o@&eo@;o@ro@]4.n@4E.: n@{;n@^n@)vm@Lnm@m@ ?m@.6Ѱm@,hpm@-dm@\ n@oϓn@u/n@ѥubn@4^,n@1=bn@01wWn@9.3^Wn@³ɩm@p|U?:m@Ujm@/:cn@>Pq&n@[mQGn@ Â[n@9ceVn@WuI=n@{rn@!c;m@Sm@[.Nm@1]#qm@?xm@hhTm@⣙fm@Ql@˖;eKl@>ѷ:l@el@3ĩNl@}Ϲl@Sc m@ vR,m@k_Gm@lf+b5m@ ,m@zC߉m@lbZxm@hCm@7]m@beQm@⢥m@33m@Tym@ 0﯂m@m.gym@7m@’ubqm@"YVm@Y9m@sǥE%m@*-zm@mG"m@[+m@0׬0m@=-m@2v$m@:t4Gm@)qm@hm@|@-m@6YJi#m@ 6$[m@u?bm@ѠQm@`Fm@J0m@u/T%m@,0#_@m@|bm@M|m@LI{m@$'Sm@#m@Ul@8l@Ui2m@rG0Bm@u˸qm@[?m@vm@)}E5m@u![JKgm@.=uZm@Jj[m@85.bm@73am@q^m@"Fjm@K඀m@?uLm@]m@9*m@m@HFm@3$m@qcm@"J(m@Ƅ m@Odm@F0Ym@$m@nTYm@j{m@}rkm@e®_m@XP-Zm@5ݰUm@"hXCm@dJH%m@fq"m@9Fl@0Al@4}ɺl@%l{l@TיǶl@ٛԞm@:=%Dm@T3wm@+m@NLfm@1^xgm@K]m@8Cm@Ecm@,ɦm@nJm@[i\m@-lepm@Ym@%gh?m@QR !n@Q n@EPJn@j`n@%Cn@17jcn@Nun@n@b>n@\E2_n@\-n@bM8n@k9Pn@;n@n@:vn@w0An@-nGn@@xn@&3.n@խ1n@$@Xn@$n@0Ln@, o@ᣧL+o@\]vf2o@`= %o@po@_1B#o@m ;o@-Uo@5joo@#63o@8Lqo@aӠWo@uq44o@$no@fo@ o@W~o@Y>#o@ߗ<o@_o$n@'n@mtn@z@~n@y$n@o@Jfo@Do@'o5o@9#o@*)o@(n#o@$Ndto@TK]o@n@7vo@Aso@Ӕ9o@I#n@{<n@ϵGn@"n@Tcn@&}0~n@rKEn@9>@n@+ηen@ O}n@9j-|n@?~n@8O+8Cn@mڴn@ר+n@4zn@h0yn@i#n@DO%n@Bʤn@*>=^LSn@yl%n@75 n@Kzm@9um@2m@H-Sm@35m@۹|m@,n@=n@^[o@n@ɜYn@ZMn@ޫr{n@OQ{n@kmRn@k6n@p!nDm@%D$X{m@&D{hm@~1m@m@2㋓.n@ 6n@HoNn@fڙSn@uj%$An@H_n@oWm@)m@ qm@O/Wm@.m@DEm@tl@cl@'l@̍* l@sxl@& ql@ʙ m@+$:/m@XgJm@%[m@Nhzu^m@?PFWm@@CưSm@ukZm@ km@h?{m@Q|m@im@bH@m@]Xm@, Ćl@?Pl@$ [l@t+ܜQl@'(Idl@Dd(j^l@9W+l@_ Vl@x#m@ U9"m@҃/m@xUHm@%ލgm@!7m@@m@cBUqm@oAm@R3$m@ήm@|'m@ Mm@~m@s"m@ Bm@}/m@_m@lsm@,ʭkm@ sm@ ({m@yI{m@zA S}m@ dm@jLm@~m@4]om@fm@4m@\җm@%ֵm@Υcvm@)*Ɵm@m@e' m@W~Dpm@Xʧm@p&Pm@[)F}m@&|wm@sVpm@ 9`m@PEm@ m@!l@ʤl@paQl@i!l@kl@_Qwl@gm@iޝ18m@PmYm@zcxm@5P.m@ um@TLm@gm@T sm@"ccm@P-9m@~\plm@rɢ>Ym@p@Gm@#:m@РAm@t8im@sn@,lm@56m@5 n@7-@n@~,9Hn@V8n@4AC n@Tn0m@ ӕm@fOm@l>m@"ERQl@}l@$l@FLl@-l@ G=l@%o l@lj+m@oXm@xm@|-_um@ (~m@ 6!lm@+[m@Rm@TcM-Xm@y{fm@~c=pm@rSgm@DrJm@ym@ߑl@7Bl@UThl@'UNl@vn@ 9]=m@M& m@?Cm@}3em@B+om@]|m@Bu{m@ڗmm@Im@fAm@ϥm@ Vm@Q"KVm@ηm@ 9m@0A(m@pm@kcm@{Rm@Xۤm@gIrm@ llm@X6hpm@N÷xcpm@tdm@uX߳Sm@dFm@<7hAm@冯Am@Л=m@61m@T}گ!'m@0b'm@1A2m@S+Bm@S|ak0Qm@\01^m@)$fm@m}Fim@Pam@g̘;Mm@ ?m@ 6Bm@Pm@]em@5hzm@%q;m@)~m@'0lm@7\m@ATm@̟BHXm@b snm@ݧJ m@o-m@Ƅ;2+~m@^0%m@]'m@jljm@Cqm@Ҝm@fm@"-Ym@hm@⫼m@bm@u *m@o(m@~m@u`[m@n@ >m@Vڳm@Á-m@@m@_Lm@Zb-m@śs|m@. ]m@j61m@o%Hm@"H|m@̣m@.̀m@ɺ3vm@˥Vbm@h=!Om@{zCm@w4n+:m@415m@<?m@<=]m@c>m@)Ʋm@_ʶm@w4Nn@Gf+n@}Dn@aTfn@Aښn@NrCn@vn@Gj;n@oI޶n@Qn@j}n@5cn@&-!d7n@D]t|n@4wn@dmn@ކWVXn@m3En@{YfRn@n@T>o@A=n@0l,n@no@J2,/o@pӘRo@ObVho@='lo@HMOo@ٟw-o@o@ n@n@ϸsn@\v7n@5Ko@?ۦo@nio@ZXln@i n@_+ۻn@in@ 0rn@ o@RW\o@᱕Jo@ o@N7o@fIo@|5p@o@iTp"o@`BGo@-J*o@Ykn@hB|Nn@]i_n@6xn@/ bhn@0G$n@m@%s5m@o O|m@xņm@`(m@m@CX,n@n#n@ #)n@!sh~n@Y8m@5]m@U]22gm@d/m@l@&|zl@)zֻl@:!|;l@ƾHl@vl@ﺣwm@޷SSm@_Ƅm@LUkm@gۂm@뚈m@幊m@x\lm@ԗ1Ym@kfTm@3Zm@ۜ?am@s^m@YKm@'m@l@ivl@|Bl@ Z|ll@\L'bl@@Dtl@6Cgf@l@ӉN״l@ITOll@1T`l@jl@{l@3kHu+m@JRim@uka/$m@.}>m@Sm@z|bn@b7O n@1In@&]>n@Fm@1m@V/陟m@^ëm@\ɬm@x m@^[Xm@=m@ir~n@viNm@{>0m@8m@*7m@E~m@j.m@lm@829垮m@U֐ m@ioYm@焣m@"m@W5m@Őm@YtÏm@C]fgm@]"{ym@18nm@nN1hm@1ybm@Wm@ݥIm@)#Dm@@6Lm@яJyz`m@`vm@Xm@Y2zm@G-@Mm@0O;m@bkm@~hkm@\J_m@F\m@=cm@pm@{m@eŴm@ʀxm@5Rm@om@㱪m@\m@5[m@Ra(m@ m@ǴhHm@j"om@sodm@mΟm@nj]n@t}n@η:%o@e]gyLo@?d`o@z%ao@ ]Bo@6C1%o@إjn@y/n@\J._n@\?n@'n@_-n@ݝo@;Z o@;n@46}n@Y6(n@i$dOn@na n@KlY n@; o@Ӹ3o@u-!o@I T:o@EMo@Խ>IAo@Ldio@Y]o@Ofl)o@01Z!n@wr n@)Zn@G:-n@ڋOm@JM@Gm@iєwm@͍m@ڶm@hn@Oٍn@M~ gn@ee n@k`n@{n@i_zn@]in@ť;7n@Jp~Hm@RLCm@gnm@aGvm@Åm@5Cm@/m;m@Fcn@utun@k m@6m@k|m@oݕfm@@/R/m@B{ !m@yjQl@Rl@Nsl@Oܩm@5$YGm@m@p {մm@%x!wm@[dm@{Lm@ sm@ڕm@]\m@.=vm@jͺum@[7:sm@3Mem@b5Lm@E:~8+m@fSYm@6hl@g= 궶l@dll@Vl@7PEl@h=\al@Bel@~hl@*l@$m@2|s.m@DbHPm@+fzm@$m@<m@3#m@<š n@Fn@n$n@ݘ{T#n@-Ɏ2n@m0n@5Y2m@6olm@bm@6,nm@puR3m@ Qn@'n@>.n@4`SJ&n@jN|n@1N+n@_~ n@Knn@߸ n@m@1m@ogm@@Mm@gm@Cm@jnBm@`DIm@%W&m@7,2m@Uzzm@I4{m@GYtm@8m@ M,m@- m@Pum@a *wm@>n:m@2Jm@[('?zm@BRm@8D0Fm@$jm@Фm@5j܏m@hrzm@5Cɘyjm@lhm@Ӻ|om@('wm@X8dm@{B$m@7e`m@Dn@U'aZm@yDm@ψGm@\_m@MȌm@dk m@vNɒm@`|m@ ;m@a "m@?Am@m@m@W>tm@Ikm@;>plm@Q `Vwm@srm@?kVIRm@[Fm@m@]{am@]o}m@RZ}gm@<8Inm@a[em@m@'Zm@4ՠm@b&m@aGm@_R&am@Ym@F$O/m@{y-fm@,9m@#m@ikm@Ԉl@"!l@km@4Mm@Bvm@ekm@jn|m@݀1pm@Qghm@C_m@HUm@ )Nm@%;Dm@/ >V9m@T1Y0m@{(%m@\m@E (m@=m@# ym@xOAm@&m@$ [m@4Wn@M姟n@2&n@fbR`n@iL;n@dn@ mn@tn@i$u[n@;n@@n@g/n@F󀲻mn@ZwJn@7n@)S/n@ ,n@q,n@+ +n@U)n@ MJn@D[ n@~'m@ !n@tn@r2i.n@ֱ9n@r@An@s 5!\Rn@u1Zqn@n@X' n@5Н mn@/^7In@IW%n@oz n@[X=pm@F)n@[G#n@GNn@vipnn@1ěn@+x)ӝn@9Pݭn@0)n@FNx_n@2wn@PKOn@p/m"Fn@~atn@v n@ (n@8Bn@ukn@hzu o@BnfGo@W;fVXo@zJLTo@߮#,.o@S<]`o@ Jn@+n@Z~n@YAn@,X 5n@@/n@)n@It_o@|`o@k4n@ywZn@p n@Q9n@yJfn@eɺn@T/o@1M&o@̹wW;o@5fJo@ 9o@^o@)o@zko@[0o@ Ro@:xkn@gve.n@,-n@q7ʁ7n@%r/1n@w1n@Vdm@̇mP m@qm@s/m@TE#n@p!on@An@-n@Ton@cn@in@低fn@@?n@Hm@ZJm@K4bam@4j(dm@h/0m@_b.9m@]m@\mҏm@m@īm@F m@~m@pհNvm@Ϧ0lGm@bE$m@m)Hm@g'(m@l}Mm@#l=~m@['m@IIzXm@* n@})wbqn@@@n@m@pzWm@m@PH1m@ysu*m@U(m@k+#m@97m@vl@&l@&o#wl@Fbm@7zBm@ N¡m@ݍD n@h7hn@˨ &n@&zL_n@@@~n@An@}&n@:n@DHpn@G^n@./Һn@{/|-n@T *n@Q3EZn@&(n@ n@M~ n@Y  n@%n@Uin@n@ٮkWn@% n@3n@i#n@*;n@ʱDn@ N?n@v̆3n@E1n@_3C]Dn@#,[n@A]n@/\aJn@(2n@unn@r9n@$sm@Sm@` n@W5EGn@$ fn@W\vn@yP(}"n@e!Yn@̲n@KRun@P'yn@7n@(Dn@`,}n@n@04on@iL[n@0K ):n@ȅr'tn@I?\n@x>n@2ԋn@vڀ|n@un@zKtn@,Cqin@5Ln@w&:7/n@Us+n@8/n@J)n@)@%n@1Mw/n@$=n@MJe=4n@'+y n@`"DEm@5rm@Tim@U qGm@TAm@5In@Q"n@~E.n@צ=n@'IJNMn@Uv0Sb^n@F&bn@߳>n@ h_m@ 쮓m@A6[Um@K.Rm@z=zm@嘨 m@_Wg޿m@T}4m@M m@>om@#}m@m@ 4xm@Z+ykqm@\9\bm@Dfhm@xadm@?3km@ldm@hSъn@,n@3n@<(n@)mn@k^Xm@c^m@^ɀm@Ps0m@48m@%)ۭm@ Knm@SAm@ipltXm@Hm:3m@[A!m@lm@d}6m@}m@ESMm@ m@Q-(m@taz>m@VYMVm@*#om@-Im@K^m@@YUm@Im@QIym@&Ozm@[m@X"0n@n@ 9n@wcJn@* Nn@_>n@hb$n@(Ron@7n@kn@uuy5n@J+Hn@6Mn@PCn@=H 4n@5#/n@ h6n@:n?n@U$w=n@*dl'n@BQNfm@N/m@Ӆ#Icm@m@ 8fm@$]m@Tjy1m@H>}n@*n@Cpn@˫n@7n@Zln@J@n@iim@&Um@%m@R m@ʟ82m@q4m@nqm@n@?n@m@$m@) Bm@="0m@x 7m@WLm@)c7m@CyQm@ߞm@z=m@ m@#S;'n@{ 5n@ijNn@=m@>2m@TJ0m@%@3m@70Pm@Dm@ؘ m@bm@Zsm@=7m@x3m@2m@\@ynm@݀Sm@BGEm@´4Im@1[F]Um@,dm@L#|m@ԒAm@m1m@0m@߼8"m@pOS)um@L3Om@/ڌ>m@.X,m@1؀<m@B8 m@8i[ m@Vm@B,>l@5l@svl@-I2l@q m@w]VqTm@ev~pm@Tn@>apn@(~Wn@*Pn@2jT :n@] n@n@̨n@/*n@s~n@ 5n@ײn@"n@Q]On@/Eqn@LH{ m@lrYm@Y!n@ n@1&f{n@d]jn@KїSn@.2^8n@ks\&n@~n@zn@Lm@6|Sn@1K.n@tX0/n@I>][n@( +0m@&ӆm@AKz{m@"v#m@wjTm@'m@@1m@**ѵm@Lm n@ 3n@Nn@?>GTn@/n@X&m@Зzm@GGm@MAm@[m@C1ym@5nm@\bm@]em@Qm@,Oլm@I,˝m@~L9m@F.=Hm@jĦm@k1m@Sm@G n@*n@r;n@k{;n@|-n@Нn@Kxt n@cn@W n@ @(n@:n@d+͒6n@n@{OJ(m@7m@|Gm@a]lm@{VGhm@xA nm@ݸsm@m1wm@{m{m@E-9m@-Tm@=m@Mاm@\(?Xm@1* m@k͏m@m@Bm@[6m@UKm@Y|̈$m@`ym@b n@2n@Ǐ1Wn@fTnn@6Cuon@1Zn@ܞAn@o62Z6n@Ew`(+n@~>n@\w1n@Gln@۝ m@bɺ m@`@:m@'m@m@M(.m@hm@n/6Im@Lm@Tm@>xwn@Qpq3,n@u'R.n@ZQm@|n5Zm@2m@2hm@}Rm@k3.Um@6m@km@(X'm@" m@yjԜm@m@jֿm@8^^m@Hj?m@'6m@:-G9m@ GsEm@[m@ۼym@U$m@{m@m'm@gaһm@вm@U3/m@]xm@϶%m@Bwn@ەn@DxZ*m@_m@hm@Vm@騦m@Vٛm@@(m@IPm@m@:m@!2m@xm@\m@_6m@E#m@t?m@=[ll@pfl@^l@V ߣl@Vul@ jl@13l@"ol@ځILm@[hlm@DoPm@v!n@bn@Q&n@y?on@Wn@Vn@ n@f9On@ rbn@it ;n@;Եn@P[F´n@#n@fҤBFn@+`m@%-Mm@޳m@c/m@ml1m@sn=m@z2\Ձn@ր%n@Xf.n@ D-n@ 5C4n@nrݵHn@@!h[n@ b`an@-ٴ[n@*yZVn@HҌPn@ o.An@ .n@+n@}V n@k/ m@Un{m@)پm@~|m@ͼQWm@3&n@X8Cn@' Un@Lugn@^T)on@б6^n@!DIQn@mn\n@Aopn@/n@A[ n@jmn@Ynцn@4Ljn@z~n@n@TCn@#-ҙn@S9n@ n@*:F֭n@zиn@ n@gjn@M Xdn@JHn@$n@6n@tvn@."y>n@{ژn@9`kn@yn@/ߎFn@Ճn@n@ T o@i#o@ripG%o@;ܗo@wGAn@unHn@(/$ln@f'X^n@©1n@>ln@Ⱥ"kn@7m:n@=P n@m@ um@m7~m@pmm@>n@}&n@1n@,]2n@ImWDn@,;Un@q)En@2:n@'&n@g3g;n@rCnn@ ' n@^Dn@Mn@)[԰n@J>n@un@*#X_n@oI/7n@}MgEn@ZMm@ }Gm@vϵm@:Rm@Am@ham@`J{m@E-vm@4om@)m@Yqm@=HhCm@SPm@Rm@fm@*G=n@C:}3n@s:;n@ѝ<@n@E6m@rom@vλFBm@PZM?m@lSOm@/bm@墾_}m@nm@lOm@)]m@b!m@dm@Hы-m@o m@q-m@$n@%.'6n@M@Mn@WCKn@(s4n@4#n@TUn@[m@n@\W n@2m]Cn@vtNn@jx9n@n@Үm@. Vm@"7$m@m@Wj m@Cm@u!m@9Znm@t%m@!-^m@#BߟAm@am@,w3m@܍ m@@m@TӨm@MAY9m@Ozm@ m@Z8m@{ m@IsYm@(o/n@#螏en@)݀n@ݒn@Buݘn@^n@\$Din@۸fl_n@c>_n@ܳJ^n@Qn@Q K;n@<+n@]_7)n@ NY)n@b] n@ ?pn@5m@TL`m@tm@xVm@z0Qm@"1m@I{m@B/#n@oZAF7n@89n@ o/n@~*n@2k n@g|m@tRm@2 m@Qk3m@r>Km@hgm@ʳn@Gn@;ƻ n@>P@n@=Fn@a Qm@Um@`Wmٰm@QZm@Bd3'm@m@2m@fm@O_m@_Jn@LҖn@zn@6zm@\m@Բm@Ŭm@&sm@4m@ H&m@O%m@R/m@T{m@{Am@Lm@/W5vm@ޑ:uOm@m:m@JUKK2m@Sqa9m@ROm@kim@)m@1m@Am@.o m@kW=m@`ݎm@lUm@dBm@vn@!n@CVn@Nu)+m@byqm@dm@'IHm@3/m@&I}Km@rh?m@8m@]m@fm@-Cm@UѪ!m@߱m@0Wl@}>Ll@ϵGbl@%!l@ňԮl@l@N1l@wڡl@%E m@sF]m@c?m@%FZm@D)n@uy]n@)jjn@s>vn@3jn@(6oðn@8.n@5n@z׈n@*!h};n@Vn@2sn@v)n@lm@L~m@v{[m@ݮm@ˀ{m@jn@ܥ.n@Ic` >n@61n@L0,n@k:En@)̿"pn@.in@On@Fn1n@9 Mpn@$ȮPn@:!.n@ӂ, n@oCm@/X(m@3m@puqm@E^¹m@Ŝfm@W!n@$Hn@̍@]n@T , kn@byq`n@s1ɢKn@DJn@,SWn@Н`n@QPXedn@Kgn@e`n@4L[n@wgn@'}n@Un@b.Fn@vBn@\ltn@ح7n@)Bn@Wscn@v5Wn@8WI$n@.'>en@嗍n@,qn@4OϺn@'/ n@En@Nxɬn@#fn@9Gn@ܳn@An@9[?n@4d;o@y{o@n@ n@FMNn@e瞆n@n@Pvyn@x3n@r,Zn@+N:En@0C n@+pm@YJm@m@-Cm@:m@rBm@P: n@{1n@L2YAn@d(|1n@an9n@VSn@͹v n@&;S#n@F,[Un@?=ۏn@Vn@՛V>n@\IWn@:cn@-In@dn@:m@3m@Fm@'$m@dU n@U&n@U[$n@}s n@m@'Tm@Vm@#~*m@$|/m@Lm@sf%m@"n@͓ųn@?n@<{$#n@B 7n@^6Dn@6Bn@G.n@tcZkn@nҲm@m@Дjm@um@Cm@iFVsm@fCom@Б%n@d}^_n@^n@,n@dbn@Wn@>bn@5@{n@`?fn@4$]n@Y]Tn@5En@ 5j5n@-(n@7.n@-,n@ln}m@Sm@ m@D-8m@"l"Jm@wAm@X,Vm@o3m@bn@*"v*n@Oo)n@u4.n@" n@rm@m@= m@rzm@*m@;mߩm@m@Ef m@m@7WG!n@e5 ~n@Ɗ7n@!n@{T^dm@ֵm@Egm@<m@']øm@2RNm@8m@cqm@ m@eݽm@Am@S|m@Im@y3m@sΑm@Dm@g۸om@Mm@ Tm@R(m@Um@% m@z |m@/Q Շm@N{;m@gm@Ά@m@@平m@ "m@z@d"n@1>2*Yn@Hή>}n@M࿉n@=\>vn@R\n@B'F^[n@SOn@Z؊n@DK=mn@;[n@gzv8n@ZS[om@O4t"m@1m@A\m@-j{m@I~ n@r"n@z_n@,6n@in@`|6n@1Xg}n@〓en@к+n@n@roln@gDn@'F8xn@ Փm@*}:m@z0m@z m@+Mxm@+m@hm@p*n@0#Vn@$])mn@ Xtn@X _n@M6En@&8?n@U%Cn@Q'Bn@K@n@vXAn@k=n@t6n@lm7n@mBEn@6c[n@n@!'n@-󬟐n@cn@sxSn@oapn@q_X(n@ n@t!(n@RM8cn@u&f$kn@b[n@:,?n@lOSn@gfn@tLfn@!U@n@En@1n@%_n@GRn@Uq☦n@TǮ1n@^)n@n@:̔n@9ZMJn@Qn@܁m@UnRm@ Em@pwm@ m@P?yn@8n@8c"m@Fʢ?n@\*+n@E/q:Ln@_Bn@Dzn@E+n@-|3n@^vn@pФn@,5Bn@9 n@aeown@Ǖ\n@H-n@)tm@k3"m@w5mUm@|uAm@zcwm@:m@[m@e23m@ylFۖm@̌m@M^|m@n@95|Ln@an@uCqn@>uՙzn@N3~n@ Ќ{n@m$pn@~([n@=n@G*>}n@ n@[zm@ cm@'sU^ n@W?E'n@ cPn@fm@qidm@Gm@g&m@kj,m@Hn@ïn@5|0 n@EMnn@>0,! n@'Zn n@]:n@*m@lqRm@IUn@r,vVn@P;n@ܝ( n@Nn@k n@k%n@-n@ŘM\m@[Nm@^zMm@Upm@d`m@1m@+C m@jim@~0m@=rgm@z+Hm@#r~m@ߧ1m@=m@|uJm@lU_m@۪fm@Նam@hm@Stm@ȓAm@JUvm@'em@D`m@hv7Ddm@ X7$im@imm@3vm@#}m@<Sm@mm@lDm@{sm@im@IOm@km@S̸m@jֻm@|6m@=Q|Gm@6oum@݊m@ն(zm@^m@ZDm@c3o5m@Ț=0m@:R&m@m@ 0;Hl@q&l@4 ll@4|l@mV)l@~zxl@s[1l@HBڰl@Zl@i< Zfm@i?r^m@tm@%Om@ C{m@; m@U}n@e=n@ɲPZn@-{n@X uܚn@C{n@s%n@O)n@un@!b>n@;Fm@3lm@pnѠm@ m@Gm@AT m@4m@A2m@{m@grapm@gJhm@{]p.n@ kn@>LLDn@n@΢/wn@b@n@Z n@u[.m@ %m@Nìm@Bfm@SAcm@W\=Xfm@NuCm@ySm@ "F4n@`G$Wfn@hn@S n@Clrn@ Vn@J-Gn@_@~n@_n@Kn@jon@Trw`n@vn@LGn@!TRn@zwn@T`>n@lun@φJn@V3n@TJn@N)mgn@>Yn@xVDn@z/cn@Rn@ |n@H@Xn@SNn@B{n@Kn@QPxn@n@n@#oMn@~^Xn@1 n@"m@tm@ hZm@_m@,p.n n@tn@QQ2n@ n@uwn@TQ9+;n@Unjin@bڂy5ln@4hf>n@En@qNBn@U9Dn@O5aKv`n@^):Qn@XyU4n@ +n@v= n@Օ'm@Rl̶m@w;m@{Y)m@.rr#m@0m@Gѫm@i^m@vϔm@gm@bu$Wm@Nxqm@)m@%\m@fżm@HKm@//R]m@(] n@ )n@-0n@}*h6n@]V2n@VN!2n@zp=Nm@/Sm@ m@<ܔm@3m@qam@iFn@jCAn@2W#sn@In@\:n@Ʊ #n@ {n@yqln@4n@A}m@9vKJm@%?Яm@+"m@`"[^m@YuTm@ӾP4m@"}m@_pMm@|$؉m@_Θٔm@llfem@f:n@Ob1|n@iI4byn@?K=n@em@äYlm@[}3Em@ Um@um@:[Y?6om@= ^m@Q5=lm@0m@=9Mm@oBg=8n@on@_}їn@L}p-n@&n@k5eksn@-~^n@6gAn@#|%n@jƓn@vn@6اn@O4SZm@C6m@n@ԗhn@D8n@N n@3*n@^Dn@hBn@REn@PXn@n@?}Vn@ /;$n@,~n@#_h)n@o1'n@On@"n@*k8ebn@L:SRVn@$nn@A9\Kn@؄On@7}n@~Kn@ɲPn@nn@W"@n@Θspn@~XZ%n@;.N:n@M"i n@n@%ypj$n@iIn0n@g=8n@#.n@\Ln@o%n@ⰫLn@^q^wn@22a{n@T%Pn@ -Wn@8in@R4N n@ n@n8&pn@_6m@Vm@xm@ŞeYm@R m@]m@fm@ӢXm@< Xm@[z!m@3v m@ m@pTm@uէXm@9O'jm@vm@im@{^m@ m@1=nm@J'Cm@ZN*m@i*m@_:;m@Y*m@WAm@?Sm@7*Šm@sn@dֈ n@EFben@kb@(n@^h0n@ 19n@'nHn@} !Wn@>`n@6Yn@+|Fn@Z1n@%n@[%$n@/&n@*n@\SBDn@ 4Tn@)#n@ɢzn@޾&X n@C4- n@3: n@J= n@*!Tn@=3uPm@3m@aX։m@Jxm@(b>m@gv{m@b(zm@ۋm@<޼dm@Qm@M_m@!2+Am@)VO~m@^ um@%om@T~2km@=bm@_Sm@꟯@m@:0m@> N%m@gR5:%m@B2[%m@v@m@=m@T++m@4Em@r]m@)Ueim@x^Eam@!Im@iJK.m@y¾m@cJm@C(l@yXl@ ݒl@3;l@!BPգl@~$Ǜl@$$Drl@M20ʉl@75l@wl@+l@-AU\l@IQ8m@Lj@nm@&G(m@٭m@ ]0m@?Rm@WwGn@ŝGCn@+ Q}n@T˯n@øn@,n@etXn@*`mn@h'6n@rG6m@1y|m@%}m@\?m@Gnm@Jm@D%bm@ZXm@Ӏ0m@F2Z(jm@w ۘom@1صtm@Ű"m@:Dn@pU Hn@./o n@Im@׾m@{m@m@Xlzm@]Utkm@{hm@{m@6m@EyRm@ h*+n@\4%mn@jn@soTn@jn@/`!n@vXrn@{Q Bn@4ɘn@)2n@:pn@ݴEMm@j5m@qІfHm@&0O{lm@P n@n@\>n@ȵ%n@e*n@zHn@Ƙp_jn@d_~n@o.n@\/n@4 n@ Nan@+ǒn@3n@GR{Grn@CsǙ;n@o\ n@5(n@*}n@_U$m@7fø]m@Fb0n@ǴOZn@,Jn@r$n@)n@o1bn@43in@vY;n@0jn@@m4n@0Rn@㫚Jn@w-2n@`Dn@]`n@TIpn@ jqn@vU`n@jBn@N>-n@8F24n@_kTn@Yesn@U3un@N6$Pn@6,n@Qym@n" m@ٕ@m@Sdm@a!,'m@6%>m@cm@1 m@?cm@Imm@+em@JAm@]! m@clm@SLm@,+_m@f8Gm@\ m@;m@=im@1NHm@5;m@~ؗm@xm@eHlm@#a[m@`zm@D=m@ 1lm@} Y[m@-i$Fm@{rNm@E|-im@=m@,m@nBm@Ob n@XUx'n@?M!9n@ӁKn@אԷ hn@Q^dn@@n@%On@%kMΰn@0(n@|Ln@gu/Fn@n@cn@x\$?n@|n@hI n@kn@قAn@Ed n@1n@ .0Tm@_m@m@)Hn@r&n@P6n@o =n@|Gn@ő%Sn@`rWn@7 wpRn@JrPJn@_s.Cn@;S^;n@pbz8n@7Y=n@tIEn@rOn@>Tn@ǓLn@!54n@jT9n@.%*m@J1km@dd/m@W/m@J n@9+n@6Jn@*Ban@ߒJhn@r\bn@"O)Rn@;n@!`#n@-in@In@Q(}m@&m@frm@G}m@hD9gm@:{&`m@hC`m@m@!Dm@ܾm@)%im@{m@ٓhm@o~n@_n@g8en@kwn@np[n@$?$n@ܨ!,n@c %n@m_n@/n@dn@s"n@?Y n@1vn@ZFn@ mn@@)3m@tMm@JXQm@:m@Ngm@ ꍍm@axm@ahom@,~{Ykm@W_m@ҫTm@/Wm@51om@+ű)Im@[m@'Xm@-m@OaVDm@%m@] zm@IqJtm@œim@viVm@&=m@Cg%m@3m@m@:Wl@@Y]l@dpl@6Yl@uIl@¡94l@j m@@m@e KHm@ҙt3m@PTm@.<l@7l@ $9l@ؠl@z@*Tl@ql@Fl@> Ml@V_l@!Fel@436n@\c2n@YSn@8t.n@1 [wn@,1n@Uxn@q!n@P[n@y(d.vn@g}csTon@?Q$en@)ɭn@n@ mn@~Z4|n@!SVn@.E~:n@@}An@k+#Yn@닁qhn@ϨCVn@R^(#n@|Um@m@̨m@m@wT/M@m@D1n@ Tdn@ n@1ton@)wwxrn@AJ*im@%?m@yIm@,4fn@qn@fwm@ Ym@NGzm@dm@r m@Jm@6m@~m@rm@АQm@@m@ :|m@; Mm@*7=m@bDSm@~m@v~Ùm@K߹%m@%Ym@ӘIin@HA`3n@ .nJIn@Mgn@N:n@Ԅn@~1n@_n@=oO~n@LnRn@ h!'n@rzn@qn@cn@Q:n@P n@ʂ)n@XT5F#n@0n@m@m@\m@?-[m@iA n@=:3n@W|+m@"d(8m@gq{m@b(m@8t(m@obm@MRm@/Um@)M n@Gm@Om@|W˼n@Lc@n@%n@9z2n@:>n@tJ@n@87$4n@;lY n@| n@V2R-m@[gcm@2m@}.tm@vK\m@Jm@UM>m@x 4m@y6m@ Sm@nX>#|m@cm@lm@m@)m@\m@{. {m@2pm@\2rm@+{m@m@~vXm@X2N۷m@p< m@;eKm@q.^,m@orm@Mm@hn@^bKn@k8Tb n@"'n@-Un@9+n@gͼn@̳in@xrm@jAZm@-$m@A20Rm@m@Xm@1sm@ Y~m@hm@4؅Ym@_`Im@d׉PFm@EXy[m@8m@L6m@rm@_o,m@P[m@ytzm@xm@Xsm@0M7^m@!nK?m@w"m@W m@1Nl@|U$l@9>OZl@Hm2l@2l@J7Ϲl@vFGl@Rl@bm@]I($m@:nS m@])l@q!l@y8l@Dl@qƺl@n]l@Xcl@ΙRl@cϯll@QPl@_`B܇l@U{l@\X>l@}l@YAu$,m@D[m@38)um@6ӓm@?m@+9RIm@xśd/n@eZn@<~n@Q0(n@m~kn@3fn@i;n@Kmn@WMFa n@[Xm@KDm@_S,m@%c03m@bm@I0m@{.m@oEH Onm@mqom@}eQْm@6uqm@Bn@'=n@ym@eHfm@_d/m@y4m@ƂYm@ogum@@i}m@ª}m@-Em@0 m@Y<bn@_ren@4=n@pn@Un@Kn@t~n@ \\]n@2XXn@^Mn@b8_4n@6fn@G n@;m@3cm@Ot=m@,m@#um@|#em@Ҩ$ n@@\)n@` u]n@*DАn@/.n@7n@9Ztn@=/3n@0T"Qn@;ɒn@@Qn@n@X(C_n@ n@ W n@7~n@6S,n@.$5n@t[}+n@Qmm@M%f n@Rn@*Egip4n@8Qn@N:un@uƸKn@1Gn@*P&n@cΉ_n@Pw&jn@}$;n@=4n@=0n@rW\"n@ N%n@FZU)n@I:,.1n@.0n@-Yn@(Km@v'm@Jm@Qfm@4m@%/trm@m@J޾m@g}/m@2;~ym@*umm@8n$mm@"zm@푂jm@ʻ5m@%OFm@.8}m@ n@i}hWn@< ,n@4R'n@hn@S#UUm@E:m@dpwm@Iv m@XMm@sqn@pQ_ n@3 n@* n@+vn@ n@w%n@)Б!n@YD;n@qOm@Kݪm@pEm@͘bm@'uMm@stc;:m@MA b!#m@ẚ' m@Xmm@fKxm@^`Bm@P5Ujm@J5m@>r~m@Dsm@wձQm@$s%/m@ξ]"m@I.m@AJm@(\gm@3Lfm@G Īm@ý7m@Swڲɪm@ m@ڎ'Ϙm@g& m@.KQm@2m@q5m@K/n@ n@Un@Fn@n@`m@Lm@53hm@nVm@=Zm@m@Ն Ҽm@4ym@ Pwm@ am@ >Om@ 5yFm@j;CUm@zm@EDnӡm@@50m@Iem@^Z㟆|m@3&lm@p'Fmm@x=im@GyTm@Ԭ3m@kSm@I m@4l@=SPl@f6ҕl@r|l@R,l@YYޛl@5l@NCl@pl@ m@}Tl@g˧k\l@]l@8!#Fl@=Mzl@>l@l@}Kl@E6-l@5l@{2@l@z!l@Ӽդl@켍l@`9l@jm m@ ѹj/m@aEm@W 5\hm@ Pm@2m@ZAo| n@e6/n@W On@kÛan@ UjNn@sn:n@(ոm@em@(昋 n@|8en@_@w n@l1m@M1m@0rjm@:-ڊm@٠'ym@#nm@Dy|m@%Pm@nm@n@m@`cm@W&Fm@V^m@gRV*m@F\wam@mm@w+Mam@Qm@N'm@Spސm@w n@:]fn@·n@hm_ o@ n@Mn@8n@xC{qn@<*n@Y" n@6Vn@7x-n@Nn@B m@m,m@D m@yqm@7ym@0fm@},m@b Dn@9HLHn@@ju~n@W&n@+cn@ bn@PX-n@9n@cMxn@3wnn@;0n@Kpn@ Q%n@Ozn@ko n@"n@\ę6n@PM=n@bhIn@F`.pn@K( n@9 2|n@qWWn@P檪An@s&{Dn@^un@$hn@vHn@{n@jn@3ꘃn@kʈ(Pn@d2n@*);j)n@kϰ &3vm@ZQ[Im@%m@rKbm@nl@2Rl@9el@G$m@VэdPm@mnum@ה7m@;m@79ְm@m@`Gm@Jm@m@9R'tm@1`y&n@o%n@n0n@J:/n@\8&n@ $pn@}rn@11n@F n@Kn@D\n@[km@Ƀfm@\$m@M:m@ҽm@Vm@5`Jm@v*#2m@%Z@m@Odbbpm@:UxZm@~ZUIm@OpKm@% em@]wm@R;$m@jS(]m@:*Zmm@e^m@ZD*2^m@kWm@edCm@Ki?c)m@V%Ym@z- . m@K`zl@"bRl@f!dl@B:e9l@Pl@YaQl@3٤l@ۮl@Z_l@ Gl@ n@& jn@׺yn@y #mn@Q1eoTn@NI̓An@E$36n@R}])n@qEn@\d2n@pn@j ; n@qnm@bk0m@,oTom@7m@%8m@B m@&%l@ jJl@ml@!~l@;tFl@6m@%gIm@Tbm@]m@8m@R4m@((m@}~3m@9`m@+m@6]m@m@]m@uJd}m@oim@ʌ]m@O¢dm@%$}m@Sm@z>m@B5)xm@km@6 n@n@GYn@Em7n@G"m@[R%7]m@xjFm@Vkm@ުWm@/wem@ <*w{m@-m@I2_zm@3ۺkm@?q;|Om@#jBm@GgQm@Aߐ6om@ɇ=夅m@(Նm@sQvm@QfAem@j)MZm@Lm@׋o&6m@:D!m@Vm@/m@ ܇m@7$l@3l@h l@ż1ll@Dl@ɿl@M̥l@̫õl@Jl@l@ݿ=jm@ m@@ oRm@s cm@:!Cm@Qrl@ؖl@G{l@Zl@"bSl@Hl@W+ʑl@堟4l@(Yl@p:ol@h-l@l@h7l@3m@\<8m@RDTtm@10Lm@3|m@ }#n@ n?Fn@1´Im@ًJm@DQhAm@^bm@@n@=o4m@̀m@Ym@R.Yfm@qwTm@'̫Sm@oo=Ao@{~o@ɼo@J)0Ro@㽍n@n@{nS[n@;:H n@@JKm@bxm@8xƦm@1@jÕm@mF m@؜m@ {I{m@ғ؍m@\9]m@ 7n@Jٝn@ijwn@a켄!o@<oSo@~do@=Or4o@An@CUn@Ein@ԡ] |gn@ RIn@vc n@dZm@zc n@r.bn@n@DRK5n@Z`X)n@Oƕm@19m@e}wm@$Hm@[< m@v!n@a ;n@a^]n@_m@dym@Q#-δm@dm@;üm@Pm@9im@V8ŝm@ ^2m@Z_Nm@Hu,m@IIm@m@#f n@ n@E{Tn@D>m@+rnm@[Bm@[v m@V` n@P2&'n@#i/1n@in@>Q7m@rm@*+m@ Am@~ǀcm@zjm@f9m@V J8Zm@*m@oXm@fim@4>n@%n@$*5n@0Ωr:n@&T ;n@>n@_"=n@y>0n@5:n@ n@m@dhm@Bj_m@Gen@qLn@ mn@Oe!sn@k t\n@ Fn@9:n@9C.n@]r"s+n@^XI#n@Ztn@)ғim@%W͟dm@=4nm@T=m@@'Gm@=eւm@|l@>w l@H*l@Ѐa{l@-l@<Н7l@{*Oݹl@L[zWl@*!{Yl@3BҨl@26l@Ux>l@WTl@c\!Km@_}m@`m@=%Ym@HM2m@Mm@˲3m@Mcsdm@˼Jsm@[m@Hm@OyPO"lm@DSߏm@ f֟m@fm@ \m@m@Ieڸm@rm@+7Qm@w\m@[Jm@ n@}8An@${Ym@AOm@x|Pn@{*e|n@xL^{n@cKQyn@@an@F ZSn@*PILn@?n@^+n@}7 m@Dl8m@zm@?CNm@cO_/m@41"m@xdfF m@a{cm@B0(7m@[Z m@$.m@ψSO5*m@N:m@h[@7m@wdjm@pl@#=&Pl@Upl@pl@l@Gm@L9̂m@| KY n@cV77n@#fo@tCo@~On@;kfn@uɖn@%@n@a|1n@a{b0n@#`A_m@c˲m@m?m@U rm@02B-m@fCl@ˠ^l@7>l@= l@JLl@HYh3 l@5al@" l@=*m@+Vm@Tk)Rm@Xu.m@*%m@K_Mm@ --gm@,Em@N)+m@*l@Vm@ӣem@Ud oXDm@Pd>m@o0&m@׌.m@}l@ϙjl@cMl@Mel@1QU_l@-kl@Ql:l@Oǹkl@c h'm@0n7m@5f+m@Kmкm@$l@friWl@YSl@p.m@RH m@HT>l@CKʚl@O<-l@CEnl@l@ Il@ϻl@Del@l@WUfm@!%4m@_m@(Wm@Hq m@bkܠm@yj¥m@o/m@m@m@^m@: ̅m@dsHm@ m@~i{m@Xo?m@ ;zm@U?m@Vem@3 m@ٺom@e[m@#>cnm@RThGm@ѣ]m@m@c-m@T5pm@|gm@ZaOm@1m@8$n@o!dJn@da'Bn@!Ao@-lLVo@Y`o@ӭ'o@C}n@]$In@m@񏑴Fm@tWm@Ekm@_|Zm@@LUm@9Mm@l`Lm@C#Wm@ 9{m@σBKެm@=_m@-@5L[n@PDn@.h%n@}to@[vo@6Bwn@^Ln@a{hn@4n@\:en@ۼ\;C!n@(Pn@}dm@_om@I+m@5Nm@A>m@)ۓm@@gUim@_2Fm@om=5Gm@I^pFhm@tm@ͱa8m@vm@+;efm@7$_m@j -bm@ >Vfm@gcm@mB,bm@ކmlm@z+:A>m@him@W m@j qm@(nm@l.m@/m@n@?)0 n@Gn@TՁ.n@+ΕDn@ia^n@nn@PHlSgn@u]Kn@s(n@K%sn@-n@Nt[m@ejom@m@0H4Em@hiD m@'m@vn@ jSn@yd"{n@.n@ܖbn@C,n@rm@'im@Ljm@Hm@>cm@cm@" Om@!OEn@hn@Ҫn@e1n@M{n@Ƣrn@w#on@5oI`n@Z+?n@>= n@Zm@g wm@RHCm@cĺ+m@w:'m@)]*m@SH0m@R0m@I5q3,m@0,m@f9m@YFNm@}nem@'U*Ixm@C`Xtm@Lm@Lm@$xl@$Зl@PM&l@J9$(m@aߕm@'' n@ϥn@Ƅ)o@C/Jo@Xo@ԅn@%Ϯn@n@ n@8KKn@jm@G$m@ĽЀEm@eۏ*m@ӳx:/m@Y_;m@`'89Qm@7am@ `om@XƂm@b0am@Wm@y۲.!m@[U-`Dm@(0m@_ȅm@:oݺm@$'}m@m "qm@]tSem@ w}m@̩Em@Ge Nm@{>8Wm@Θm@oqsm@m@Q/m@h~m@*vlkm@TGm@%m@8l@9>Wl@! Ul@!m@m@[okl@D85Nl@zkm@ˊ9m@u06Bm@̡l@<6l@gl@Vl@Ml@*l@6~l@\Wl@#O m@dV?m@dm@]%m@ѮI:(m@ ;e?m@_dD-m@5S<m@df m@(=hm@s;.m@&`L@m@c.m@*\]m@vJm@]Lm@4 l@Um@AnLm@m@ -m@&e!Am@ҦLPGm@mIm@4>8Wm@`mmm@m@ }m@{髬m@=m@-m@Asm@ im@.b:Ym@ovim@9m@F zm@ 76m@?Cm@&m@*em@ m@|TCm@hVm@Z vm@ƔCm@6v ӷm@ ^l@Xm@jF&m@QVO';m@Zh5m@4D2m@3h;Dm@ )Tm@J3oTm@s'hLm@iW0Km@kOm@P@k7Sm@ubXm@h>[m@OX%Pm@AAm@J!9m@isu8m@z78m@h8m@ R,m@X e# m@ l@NYVl@oKZl@3Dm@"Nm@%m@I!m@1jm1m@rWDTm@4 m@4{Dm@ĉm@Im@ل?Lrm@$3m@]YWl@.l@p#m@i2P[m@&m@ Sm@Q;sTm@ReFm@|Qvm@3m@ dym@m@ppim@kͭkm@d9bm@Y4{m@(oꞖm@#qTm@9"m@ȷ2;n@stun@ 0s o@Vo@n$fDo@jpn@ՂМn@d+n@;Im@ݗ}}m@[\m@RD=,m@l#m@?=Am@ m@Fm@j m@F=qm@]uEcKm@r,Lm@d ;-{m@~Tm@a,= n@m{\n@84 :m@;9wcn@$%f+n@39Z.Rn@u\q[n@82Wn@?n@~n@ʗm@iGFm@.2wUm@+ m@ө%׿m@o um@$1{m@HD#cm@I6+uLm@lk3m@fvKm@Z%m@Tm@)Vu\m@1Hm@͜?m@z+H#1m@X۲Km@ [jm@2jm@Z"+,m@uPJfm@AהWm@Zm@fm@;Dm@Ҝn@|ɽc3n@nRbn@!:{n@ #zn@qn@nn@ظwn@,n@n@"Fgn@N&3n@(rm@?m@,ywTn@]jn@Z*cLin@Tn@k+Gn@i=n@q.n@G<n@;#H+m@Gtm@s1Rm@[wm@j6j#m@Osm@V7n@1#Tؤn@8NBo@pWS8o@zo@Svn@2`Sn@#l/g^n@ct;60n@)sm@2>m@uNm@zUedm@E3Nm@7D^+m@0;4m@{l@ocl@{dl@Ul@"iO:l@ը 6l@袰l@Zۡl@9l@ 7l@,G+l@l@@i m@y$ m@?Oi"m@e/m@H%HAm@:ّUm@0 GUm@ {.m@Фm@*R{l@itl@4,:l@l: Jl@m@G'm@`Gm@,eʣRm@[`_Pm@Kb.Sm@ե[m@wlm@38m@N@:m@f[" m@y]^m@R\% jm@e,y/sJm@50^Cm@UH[m@Z8m@L 3m@C^m@m@_sm@m@rre&m@^*;`m@PݏΞm@^֪om@Jɥ@m@~˭1c"m@*(m@EKm@vbm@bm@'Hem@Ǔqm@P0mm@"[m@ҝ#Ym@Elm@7~m@$m@Svm@*6*cm@3nSm@ͅiRm@)sZm@F`m@T[m@5iGm@\m@y"Fl@VV Ml@_al@aPsm@Q0jm@ F:m@,bm@F;m@x-.m@YYm@`I ~m@Om@koqm@z<3 ?m@] m@\ZKl@Io<m@i2Gm@>F}m@Mmk|m@v)ƤRm@6Cm@n@gsSm@QJ^Лm@]C9Em@uTKm@M(m@8,)^m@}_m@0m@Pǃ, m@`m@l݌m@ܘ{m@Ym@: 0m@>Km@E%jm@uOm@ DOuom@ rm@Oѱm@K,m@d hm@C!Cm@v"m@=96m@Im@zhm@ҋ>m@:m@\m@.m@z2m@I<4m@k}5m@}ĭOm@Q]/:n@*n@ In@x9n@zn@0Xn@!>~Sn@?c^rn@U}m@͞5wm@rm@m@A#m@} ͍m@m@Um@rj*hn@(*[n@Xun@_Ln@tW}Ό:n@k0n@r`n@2~2Nrm@}um@!m@O4Qm@em@?́m@3w n@En@@n@&Ln@n 6n@)b :o@U{n@|?o"|n@~շ~2n@住{n@Z`m@%a)Bm@JΆCzm@vfm@"+]m@qjIm@_ %m@kT,l@Nol@6Jl@TT`l@Fl@fq#߲l@QHBl@lܮl@Ĥl@s9Wm@$EjY+m@*6m@`6[m@xY5m@irm@8/Cm@'g+2m@_vVm@qUm@? m@9(lm@Œm@^cKDqm@9sYm@\Um@jfjm@n^2m@8Sm@Vȥm@vm@r؍m@im@eQ_m@Xqm@T< ̋m@Nwm@_m@hOdm@mWVm@=H2Xm@ʋ+E^bm@Հ(nlm@/jm@Q1FPm@pH)m@yl@E|l@w5l@n l@&3Rl@Ul@Ӟ2l@R'l@%7l@[F.I m@l:3m@HRJm@ݛCm@kVɭ&m@3Rm@U]ul@um@zx\Fm@Fsum@NNQ;}m@KWm@C 7m@Hm@q}m@@-m@.m@!Wom@3hϩam@ m@̎m@TU n@C7b9Bn@een@ 'n@u pn@vn@4o@vثn@]H"|n@rM#W1n@y9g%m@:ym@ 3m@B?m@%t{:m@^4m@UXLtm@9VXm@ .n@%~n@;n@ºΌm@pXJm@| m@} m@l$m@,D Om@!X~m@Nkբm@>I@m@-IM m@6m@ ڸxm@=fm@ P.\m@D~Im@VV/G&m@p8Fl@nT'dl@"~l@Lsl@l>Tl@;l@dm@}(m@> Im@ym^m@~hm@jm@_amm@u3{m@-Nm@0m@}m@n vm@,In@<>n@)tan@|{Ubun@IPn@?n@1n@$in@4Jn@f3/-n@+ tmn@spDm@3-m@>+m@ψѭm@X m@m@Yfm@ Lm@+Im@-m@^&m@U',m@mz%nm@0m@L>m@6,n@pWn@}lKqn@BER2n@˒>n@Ӗn@ n@Hn@ }n@.kWn@gH+4n@JL?sn@r'-m@ۭ XZm@;]m@B<m@vK8m@fym@w>m@E)n@@7n@<=n@Ԥ-:n@.7Cn@j*>8Ln@ęI2n@qg6m@dm@Eؑm@}m@*3Dm@yf0m@vn@׬In@y:pn@N[˃n@v3{n@/pn@`In@m@˒Lm@Lɑm@Mm@ZBm@Wҝm@2m@m@hzm@Im@m@'oKbqm@2atm@*X%m@P?m@m@ +pm@+,^m@Gv ]m@H$em@< om@n^pm@Xm@n[(m@ /~l@etgl@7S,l@%qm@)m@C.El@Xwl@YSl@N#8pl@ll@Kl@[B m@FȄ m@u\m@* m@m@=m@bٗ@m@zVim@VzAwm@+Xm@6 *m@P´>!m@/7Cm@B3Eom@* Gm@yNxqm@:&ijm@m@=-n@me/En@IV=Hn@ud1n@m@ ct4m@$m@FKٻWm@p<sl@-{5l@VR7l@l@fpl@@tm@%m@tL4\4[m@ψwtm@S im@LԹn@)~n@mn@Gvn@_u n@_o@vDPn@O`un@ȯU]m@03m@ !m@J&Vm@̈́pm@cin@; y4n@k!Sn@hln@Rtn@$zڋn@؆n@#%n@|l5jn@ߕrKn@n@ٓ*m@S~xm@T=ȩm@Lm@duHum@Ԍ: iCm@ҩBq'm@԰]m@@Il@!Yl@TCNܼm@x9Ϙm@5F&m@i:m@ m@0m@} m@x"m@ؘm@ tmgm@Bsm@?1m@8nm@DBC;m@Wm@Uvl|m@@;Czm@g}m@Mi {m@3 hm@:ٮEm@% "m@-Em@Sm7m@75Hg&m@_"a#m@ Vl@j{l@</l@Όl@qҮl@wl@6@Rl@n"l@؉l@;tB%m@m@\m@;m@<% ^m@!hm@BkMm@`!m@m@K#$m@SSXOm@Y_Wm@'Jm@OWn@ピr8n@Hy0an@˹]n@Ɂ/Q,n@Vm@om@ҁrm@/(;n@Nʗn@)En@>9&n@kyu˩4n@ɜLZ/m@Frm@qۇ=m@!8m@iam@,Em@wuҹm@|>4m@ on@^Z>n@\-Gn@=ܾm@zH=Im@Wim@M4m@S1^um@t m@δu&m@nj}Bm@zMm@G'aAm@1%m@6%m@\l@I l@Tzm@0!m@&m@ ]#m@9m]m@/?im@}f?m@!#m@-rl@tw<1l@dA m@;-Lm@o<-m@f6m@񗫌;m@̨ EDm@rVb{Wm@ rm@B7m@}HFm@m@N n@^6n@1]n@qtn@ ivn@ӗ`X`n@6!;n@Ìn@VIm@G9-\m@f%Sm@:m@@m@*?ףm@ ?m@>ym@UMDwm@;xm@Ix=m@j%m@@{O m@$m@sm@qjm@3Om@Hkum@[Dl-n@)!?"CWn@GjU:tn@D|n@X|ŝn@-A4wn@\^n@p~l[n@EI)ԙn@9=n@\ـTyn@]?Sn@h쭅 n@z︳m@!.`Om@ll M[m@i`m@`{^Ln@.En@~)AaAn@˥nXn@Dn@Ko@G>o@@ho@0awo@зbwn@U8Ln@W~m@3}?Nvrm@ Rm@wmbm@=m@k@|m@|﯋n@sxn@A1n@^XUTn@K(v/{{n@ O_n@- )n@>~n@B3yn@Gn@2n@!՛m@q&]m@y}m@B>Eim@aIm@v5j8m@N|Yu(m@*$m@%m@=H m@xr=m@BhDOm@Cm@޾T_3l@Ps qƎl@֥ۿ^l@5l@؁l@W l@Vthl@%=4c"l@Yd#=8l@egIl@9Yl@Sol@Z6Fxl@C@#l@yl@l@Gal@rAl@Nڬ) m@[#m@ř5m@u>m@C};m@+.m@@eEm@~m@Orm@-m@ZuUm@2bnzm@VQm@fLm@p)n@iP n@my/wm@N=*m@Pm@I"hm@f5m@CJym@RX[m@y?m@"m@Ɇm@ >m@ᘠSm@h`.Km@;k66>m@ @m@}zXDm@Ӽ6m@  m@C{l@cWl@q;e+l@Hc'Ƚl@] [&l@'dl@=kl@柼]m@۶1m@~tm@/.m@!]=xMm@Ἦx]nm@!pm@{jDOm@]I#m@{k m@Gm@?_(:m@m@1!m@1J 0n@  >fn@Y+Hxn@|Zn@ n@kSm@Rm@m@tm@+Bn@,n@"2n@fIn@QYm@)cxm@~8dm@5?n^`m@Ռbxm@*xm@Djm@,X(m@+m@?sm@b?em@b4m@YIEm@*m@e7m@`9Nm@:^>m@]<{m@߭Rm@=[Hm@&8Xm@x͚em@FTm@[6"m@l@kl@l@l@_, m@'3m@z{#m@=$m@9Em@*LGm@Cu m@U)]m@!셆!m@^m@$cڡwm@Dm@br,m@# wbm@<}m@Z>m@!m@F%m@5 m@\F6n@ B Bn@Gdn@̩ܶzn@i=?n@]>wn@ fn@4(n@=d|n@Mʕsn@".\n@=F*n@fm@ORym@7lEm@3sm@VQ{m@vޓn@v%n@e皁n@?^cqm@Αim@Vm@*NH͔Gn@OX I&gn@&sn@ 6tAn@Hm@(M!Vm@(~50,m@%m@z&/Jm@Y&vm@ Еm@J73Cm@Mem@qެ5 n@m@jpm@#m@ڞIm@'+m@Pm@DX8m@p/צm@m:m@x#m@9}m@n'gm@҅m@?sm@m@Im@T`R]2m@!m@Qy;m@s"m@m@n=m@x m@ZZ m@ ԯm@m@]݀m@ m@ 3pm@/ am@Zm@ Xm@qOm@a-G7m@>m@-l@:fm@3 o=m@ >m@OXm@آMQm@,m@Ϥ>m@0Um@j#Y?xm@S#; m@6vm@REm@0,m@%R 6m@I1"m@h km@G *Xm@į1n@ͫ s`n@`]n@K,n@Pm@Ш;m@ Ŝm@xG#ӭm@$Kum@}͋,n@ PCn@FC!n@.tm@oPm@Zm@Xm@ rLm@^F6m@Kn^rm@ m@u̼m@έm@vx ǁm@Pnum@{m@#7^m@\m@.*^m@HCm@K m@xOum@ m7Ôm@,6vm@S$m@&Sm@Ic#m@ Kkym@߿l@'Bl@"r" m@ im@|)m@:2D)m@FS`#m@o"a"m@@p+m@AixE;m@eD!Cm@X7Dm@opXOm@Rcm@+Frm@M6g~m@ًȖm@hm@%Wvm@rzn@ %n@c`+n@},+n@a0+n@Sl(n@o<6n@2Dn@N7 m@}~ҩm@$jm@ٲ4m@Hjm@xZ$m@ cLm@ wm@kmm@1ʼm@L]m@m[m@m@I&qm@ vn@qd9n@~4ran@|}n@hdzn@k+~n@V~Jhfn@UqFn@3!I*)n@uWn@B| n@nn@:n@;Zm@xmm@t8l@}:l@ڦmhm@Kn@iu['n@E ա'n@Sn@PHa8Bm@Am@PyuVm@L،m@y[a|m@#ՑPm@Rhm@>"m@3U:Wrm@;Ym@?Dm@'eEm@bWK^m@<_wm@Zhm@Tm@5B,=n@gn@+1tn@ n@&Vn@t=n@%Iin@@$n@m@m@(\!m@xfm@iŁ0km@- Sm@ʚrbm@H[am@pwt14m@u$h m@,+l@i l@jױil@x l@zk@0Vk@} k@U xk@ݒk@Kb!k@Yck@7k@+7l@&+l@oPGl@E8_l@ ک{l@' ql@&yl@Vl@wdl@ȟl@Q_sl@IЃl@*l@0*l@?| m@ lym@G,m@ː]n@cym@#M]Kl@&sZYl@tf/Om@IUEm@m@q%4m@In@ޞ,$n@Nh n@m@oˋ1lm@lm@3Ƭصm@j78n@u㑠n@e Ӳn@< ln@{u o@79Cn@Xn@Cݪ`n@YoSn@7Dn@"ݍ m@Mm@Am@$vm@iWm@\9m@Ϡz)m@S m@_Kyl@ l@J)Vnl@xl@i*<#k@ƣCk@cNOk@JU{k@Krbk@1aXk@g fk@PNJk@oOk@Mk@7Nl@(7l@Ccl@Dl@6l@1'kl@̕~gl@o"l@Al@:Zl@CJ2l@W&l@+l@Pl@Iam@hSJa7m@:\m@^{[]m@J{qm@hYm@4~m@GꐟVm@5_lHm@Sgm@QXtm@)m@T1Jm@m@#Ym@(Km@XTm@m@X4Fm@m@2m@ꚌUm@GfQm@tGm@}#tlm@wm@*fm@pm@ Qm@km@ҟm@&!6m@9kPicm@0m@Z+ #m@F&m@Cl@Lʇll@Aq4Xl@&`Dl@Eݩfk@-5 Fk@^ NRk@~k@}1bk@uOk@sxTk@Ąkhk@v9!zk@hk@zWk@ȶ9"l@nQl@yrl@ļ|l@l@Gtl@]>l@Yl@;l@^l@#(>l@p=l@(Dl@8O+m@g>Vm@Qvm@)|m@'/ldm@\>m@uP߳&m@/m@׸~Om@nam@4 k_m@6H?rhm@ym@8ebqm@5vpҴm@Df?Ϳm@]m@l[ m@Ͻbاm@98m@$iHm@Gm@yօm@f]m@ m@ :7m@Dr!‰m@Hm@|mLيm@}xR2m@{bm@Q8m@^Am@e&n@n@ȂVm@3vB#m@Az*m@U vm@$!Vm@$NDm@N1s5m@{/m@8!sJm@G|08|m@Gm@w+m@pmm@8om@7!Cm@\5m@5@ϓm@tm@sm@gc(m@Råm@fm@ځ~xm@Pm@ʑm@:m@m@Q+Um@N* n@:`)X:n@ՎQn@e Pn@jE3n@:m@͋m@PUm@O9gm@$cm@ fm@35n@ތm,#n@w:n@ Z n@͠m@3]1m@Ա?m@1m@mym@e sm@͉ m@9]m@}K^m@z1! 7m@An)m@(ՈBm@k֤cm@=- jm@kWm@2>m@p4m@)Cm@̼igm@྅m@35m@RWm@:`m@~ݺm@Zckn@:kAn@8 ^n@I+Zn@0n@Dm@ۅm@yzxm@ zm@Vqqm@!Fm@H8n@L3n@G4n@ ʚn@&Hf[n@Tfm@TgS{m@[n@"h.n@W '5n@en@j?m@0nm@%K_m@.2m@["m@4Ol@ Ol@P,Al@l@رJl@%L /m@q/1Ln@0o@tsLo@g?Gn@wO*kn@cm@jXl@mk1!l@%Hٚl@-Ќl@)5l@½bm@:4n@2bNn@'m@r m@6_m@n@Bo@hQƛvo@k0n@ywyn@`}n@3Tn@cϜ6o@@;*vo@n1xm[o@eŘ2Oo@A;o@`n@])n@ jn@€ծm@)|im@PdJm@j>m@W}ɋ m@\Rl@pzSrl@Wo|l@EMr{ k@Di&k@_8ڨk@+k@xk@y*jk@81kk@1dK^sk@Ǣk@58k@$k@2l@3Fl@_~hl@#~l@Gq4l@ Hl@۝l@}a~hl@YYl@yNrl@6 dl@[(l@|[m@\mK"m@V&HXm@A8g(m@?Dm@Iipn@G n@f.m@*m@M2Tm@bm@s̝m@d:m@xm@D m@wgm@Ө]m@_m@mvAm@BAxm@4tPm@*)=m@Qw1im@5Ѥn@"ጘZn@ kn@?bn@0b@n@TfTRn@&im@6&m@Km@m@o鿙n@Pt1n@#%#Q&n@eꕜn@v"ݤ?m@zlm@oԧm@um@6דum@`m@m@i{m@xdm@TOKm@ a:IHm@ B`m@5kxm@Zwm@7^m@@m@(18m@pXNm@UrJ)m@2)m@ m@:_Wgn@l]n@?xS)n@d 2n@|z?n@F_x4n@YEn@"V8m@3m@ǯ8fm@oPmm@(W n@ԵBn@}w`n@>&\n@3:n@:!n@ʁaDm@9$t6m@P"s8Gm@ݬ֪ n@1.n@+n@Ukm@\Hm@uZPm@."uZm@Kc[Qm@`" ^Em@+7m@`>%km@l]l@8 A_l@6N|l@13&k@*al@=l@xm@Yz0n@!?n@F&n@D1I!n@ m@ m@~3Gl@Xp9cSm@.p0m@"jZn@)IQ2n@Km@]m@-Tn@" ۓo@Ӌo@eMfo@kC;b)o@ " zn@Sjn@HQo@ԙo@o@L= po@|L0o@[Lsn@ďLn@c6m@Eu@im@{mm@#mTm@um@@/l@SC{l@vl@UYl@3eUk@ik@,=}k@Guk@ ީk@rqk@BCk@N`k@iՎk@'0k@[k@"@3k@r 1l@5qel@R6Kl@pel@.ȭl@^jl@?l@€zl@T?.l@_Kgl@;l@:m@Wξ\%m@y3m@ӫ#jl@ql@H2Wl@l@mbl@Wq-#m@OE*_\m@ym@LAm@`m@kJ}m@0m@vHm@d1(fm@+jm@6xNm@<~ m@OoAcm@ ۓ+נm@JJɪm@FB,>@|m@c wm@xm@ohdm@XB5m@a9Wm@m@؅߁\n@n!n@F5xn@"Bm@Tm@m@䜑m@s ӿm@Uzm@>S1m@j3U0n@`"L\n@`i Kn@Νn@^m@i¿m@C:m@{gjn@}Db>n@e%n@Inn@_n@I+ n@x n@qn@ `-n@dfn@\mξn@my7n@Ĩ2n@{n@"xQnn@vNOn@ P.3n@p2$n@!m@!rh_m@d,m@dڅm@*up@fAn@QVZn@a"Yn@~6o@Oz*no@7a<&do@|y,o@h3n@;n@[n@sem@ta;rm@1C*7m@UMl@idl@Ugl@}әyl@e֣Sl@ nw;k@UZ(k@l@]1 l@2`Vq'l@p=5l@8al@Qݎ3k@Bk@%k@k@yGxk@G3+l@ĉZl@֖xl@ى\l@1qSl@U)l@>Ql@l.l@*B%.l@l@l)m@cmb"m@W/ b:m@! Am@=%3m@  \m@7 l@l@r l@Uul@watl@>l@tzP6m@qum@m@JNm@}S/bm@6pm@sm@etgɋm@z0m@R% m@GOm@:V/ m@Мm@cwm@Nm@j[ qm@A֋m@ 狥m@*mm@tQm@m@s˳n@ pn@bJn@8bn@ }n@@K m@{Sm@Xsm@UW֧n@\p'n@Yn@=yn@Emn@D3n@cMm@senm@em@|Zn@;;$?n@= Kn@)Kn@+zOn@wۈXn@ίiBn@-^՛n@Łl3n@4yn@Cf"nn@-Hln@IϜrn@$H}n@{u"{n@ܜjUn@-ms3 n@⎨\m@m@lzm@WgM~m@om@<%ym@m@J6Sމm@5Vm@km@ m@H%m@glm@ Αm@m@"/gym@ltm@/Dim@˫0՟m@2m@IJ?n@8/%$n@:50n@\K«2n@NH0n@f*U0n@0I8n@iH=n@Ei?;n@'<7n@r|l3n@w%l5n@ڲ3n@9?%n@EhX n@wo1m@Im@%tm@\ Rm@Jm@^ vm@Om@4sm@!lm@RJm@m@\Rm@$^яm@-s~m@v)͔m@yLɑm@>[Em@m@])n@@GLn@wgrn@"en@>n@wn@:m(n@&qn@Qrޓn@I6n@=?o@No@hR>p@$, p@87n@Yn@Ltn@n@eǠo@$w]n@eTn@NJn@g6f;n@ m@d ;m@ɑv#m@zPl@F%l@\l@Ѥ?l@Z*Apl@fÉl@$MEm@yAmm@fUNm@Im@11pm@Y):K)wm@3im@ȳm@8;$^m@mcm@Dҋm@y7m@ )"m@ E]m@%0m@ܿXm@ Zm@c> m@R;n@Fn@4#n@.)n@ C&n@_[pn@yZGn@D n@I8W,n@\Wc8@n@*]n@wkun@Z| tn@i6Un@g-n@D_jn@,&n@Gp9n@D Yn@`dmn@Mwn@38+n@˩7ڌn@R\n@u/v1{n@ˈDqn@|vn@`Iӏn@l#Ȗn@O⩸n@8$n@{Rƻn@ 2n@|n@can@נ$n@Bv1n@"on@9Tq=0n@֛~m@(ޒm@ V0{m@;xm@y<|m@|em@s(m@%m@5ߡm@eTm@71m@m@FӐm@Sm@g)] өm@\n߫Ðm@7Јm@s3i׏m@xe ,Fm@[(m@$/ATm@:y|Bm@9'm@Tm@x!'m@huimm@?*2em@~m@k~m@壞m@Enm@@?P+m@C;n@sko@UnIo@.o@@#,|Pn@jUn@ttIn@In@N: !o@孆LLo@W o`o@%Ea/Ro@ƿ_0o@vn@U[*En@c)8t-o@o@.yMo@0O.p@KZ!p@;#foo@ρQn@LR?n@tln@ ӛn@2n@p On@S{&n@Wm@m5|Pm@ؔy/l@e"l@H(MPTl@5l@^Cl@xعvl@Z+l@EPl@5s[l@,0-l@D>+yl@l@Ψl@kUFAl@l@Fl@38el@ Ll@R Kl@~S fl@X]Bl@l@x?l@xl@75l@Xl@#l@zl@R t6l@$Dl@_!-(m@<0m@ P/m@@E_m@zrc-ll@Ql@joN}l@U3tl@7i~l@Ax5l@ Fm@3vum@.8/xm@D{Fim@Zbqm@QKm@mm@Y,Dm@)m@-tm@ am@p+/m@'FTm@Pm@%$m@w n@W0n@\P:n@y2An@| ~+Gn@ \Mn@WjRn@ۜRn@B )Pn@()Qn@X|zTn@JWn@y8wO`n@mn@&;څtn@eon@!can@r)]Nn@ ~HeCn@KaKn@Pkdn@R{ n@62n@o}Nn@GgZn@tn@g Rn@Ĉ#کn@波n@n@qbn@`7fn@On@t>QIn@|en@/2+n@W:G n@T;=Чn@*CdՕn@Qmn@3Kq/n@@m@$[bm@ @?m@_Wm@@ј*{m@f1V~m@sm@_m@eRm@i m@] m@nm@am@4#m@:{gJJm@Đm@._m@:Zm@m m@Zm@dms~m@M|)m@_XSm@Ospm@3Vm@uIϭm@ in@=8n@ܨFKn@:~En@]*n@߼n@}m@%Am@%?1mm@Xm@f!Rm@w+:ɐm@ Mm@]m@eƐm@ꔿm@baYm@l4m@sm@kRVm@em@*F"fm@Qh@Mm@6CV1m@8m@Z"7l@~el@l@]lm@ $tyn@ڸaup@3"Ts,p@Z:Ko@{n@e o@A_o@\p@$!'p@>GƗp@q o@:4Po@Oڱmo@l@l@UjR$ l@u%@m@-X4m@{zM1m@Lm@Xl@ݗ^l@G9}l@6zl@2Lf{l@ܿ m@-8zAm@\`*Qm@) Im@3Sm@W"m@*4m@"|m@%NKԤm@y{m@)Y{m@ȭm@p)Qm@`—m@!3m@a$n@F"Fn@^._n@Ż(kn@ie6$qn@?c|n@4n@B7n@- An@ӁSǍn@h=#'n@uKsyn@ށtn@Dx͕xn@PK~n@^n@ԑ }n@Son@%J^n@qnXn@Us[ƒcn@Oyn@ َn@Fn@Lcmwn@xen@M\n@(Ϫn@$n@'n@@n@h9fn@;/n@KDٯn@on@Qan@UIyn@#WYn@&|(n@ZY6m@0m@'ohm@s9ۘm@9m hbm@^U|m@Xv/Vm@IƮm@| +m@rm@5$qm@|%Qm@Xͽ>m@e;m@Nkm@nIrp@JOp@F}'p@k&Bp@QoQ'p@{dž&p@a p@=o@M@o@o=o@oՓo@N=-:o@jXn@Fn+n@mqm@Zxm@k()m@jh%m@-WYm@2 7sm@ym@)"ٮQm@F<֐c!m@Y;Ӏl@3l@$5m@9Ƕ4#m@cQ-l@f{^F=m@BfCsIm@v[l@jl@ה l@ l@."l@}:|l@:}"l@pE m@NGm@rm@ql@Yl@҂Tl@wl@ew m@Y 6m@tMYCm@c2m@=tm@il@l@Bw l@y`l@*m@OD9m@G{Y0m@E8x@m@$&wm@ɝm@A1 ِm@_(;im@:k~n@vHBPn@p -Sn@Dxࡗn@b̬n@ fAvn@G/ԯdn@CY.jXn@壆FIn@ 4n@C!n@LKn@.n@km@_m@ ]W m@Xm@S(m@ǘ~m@k$Xm@ 2m@5G`m@X0q)m@w^jm@&4ξm@['@m@nm@t[ln@s_:n@%>On@n9Zn@IA\n@(^n@an@|`n@*^CũUn@8e :n@[`D n@eFm@im@k=m@Vp q|m@ڎm@ām@v"O6m@um@.C m@Iϟm@Ԟm@ Ǧxm@,gkn@d_hn@{ `n@oVn@Sn@\n@jn@]c֛vn@4n@pn@]n@|n@h n@ywn@zWn@֑%En@A(=n@kl8n@=/n@|*F$n@Ҟ<n@ 5n@d n@@wn@;n@b7n@!Fɣn@3x m@wm@BDzm@[ݎam@gPm@^/m@G50Km@@3m@@Hm@{ m@@H\m@棛n@lSE"Jn@;Jyn@en@vUn@S ~n@)>?gn@ӿKKn@9R~)K*n@`\dm@Ywm@}?ғm@m@S9m@Cfm@]هm@m@Em@\x|m@Lj m@Sdm@Am@ฒl@o@JE9o@4X[kn@(cn@B4n@?+{n@n@In@ܽm@Y: 4m@bfqSVm@N}Im@US?m@nFm@xZm@LNm@ ɣl_m@T}m@ lm@Y~׳ m@S m@K|l@eyl@&gl@mn@ju\qn@uu2sn@(dwyn@H5&n@~sݍn@׾ލn@L-tn@m~n@2T m@/um@5ɘm@\2m@ɚʺBm@ _l@ 'S6gl@m@#QSm@`1m@Ɂm@_Ŕm@4n@4)7 o@3o@ NRo@n@ںen@v $n@[+hKn@)bo o@Vo@ڼI%p@sAp@Bf\p@3yip@}osp@ p@JIlp@;j p@Rap@T)tUp@$p@l jp@r#x(p@A=6p@b|9p@ ۣo@n@O q n@`ϵ| o@hxn@|n@IՍ΁?n@gRm@L/Xam@Z/,m@7m@ð-`*m@2^m@Esm@A"m@ ?em@3yC!m@ om@ `%m@R3l@ Zl@CEl@7)l@l@m@%æl@ 0xal@ 4l@͒ l@f>km@?f9m@ M@m@gq8?m@5=m@\5m@Y{ҩ&m@ÿ}nm@Pbl@G<4 m@?3-m@*!Um@aAlm@. wm@Kwm@ӓ&$m@pm~m@u/ׇm@,ɮxm@m@vm@"m@3n@NJ9n@Pn@Q6an@~jn@ĄWdkn@pn@Vlk|n@ձn@n@En@jvn@}Wăn@֤n@PIFn@륯n@tnFփn@?NcqYjn@Ab=n@6Zg(n@a8m@om-m@1 m@me7V+m@Jm@Jm@Ym@jҶm@m@n!m@,L8m@\ڝm@i;?8m@im@5Nm@)kn@)@#n@@yn@?n@GAm@Fm@ n@"0n@jhM"n@#n@ n@N{6E n@a\m@(t>0m@mLsm@ǧm@Im@ m@&˴1m@nkm@{han@`K&Cm@+m@3<"/um@ȋ̒%m@l@Sol@pWnHm@.@m@ (m@(n@n@hw.n@ (݅n@/*k&o@K{wo@^ &Ɏo@+Eo@ 2 $o@bFfh.o@No@o@p4o@6m p@N0p@Y]!Jp@U)1Qp@}hRp@\T^p@ԅ}wp@䏊;p@T-Tp@Y$hp@VE4p@Ҁp@^e7p@g#+$p@`8p@6Xo@:o@5N4o@{fo@'G1o@bn@:$ n@̔'n@QOm@Gm@m@O[v[m@ =pm@s dm@qOX)m@t &m@+@G:m@-EZ=,m@%Bl@l@y*:}l@*sxl@ail@Dm@ a4m@l@2l@楫l@44Yl@J:Il@h"m@b*m@cSk5m@C&h9m@'6m@Zz*m@>`m@ m@n =om@m@/TKm@Rg|m@#z{nm@nm@~c8m@n@ Sn@~!in@n@!n@kzn@;۫n@Qn@Tn@YT$n@Fn@Wėn@Sn@4ޫ\n@:V9.n@`kn@L7m@76Fm@L Mm@Qm@ m@eum@zm@S!ˍm@~#?֫m@*nm@UŤm@i~}$m@uF4m@D7Ḓm@_m@߼m@|m@#ؾn@ޞt]n@063m@#h m@qm@oPcm@?vm@Wgm@Gk8m@^m@~8Vum@sYyƼm@l/m@Gm@\m@dcn@8l8n@rdn@esm@3>m@խqm@0`0Em@;2?+m@UyFm@d 0#͍m@c;1m@ EUn@Y?_n@5i>:n@hn@ώ,Xn@uLE`zn@n@Z S=o@E{o@I Ӕo@Jio@pro@Bo@R p@=dR*p@8 % 3p@ [8p@ DAp@AKp@>Sp@ ǢXp@]p@Qfp@՘Xkp@Uk^p@2 n@-jQCn@ld05bm@d!m@|.m@sm@A¬Tm@6˓&n@In@fn@kTo@^jn@ln@n@8%Bo@nhهo@0 o@#lp@?p@|iQp@Zf_Op@j4Ġ@p@q ",p@q"p@N(p@kY*7p@fDp@q͓Hp@GqFp@Pm@\[l@aUbl@!bl@pzl@ߎl@qءIl@eHl@gLl@!ml@Yl@S`Pl@6RH9l@u.zl@JZ0 m@X m@ (b m@;l@2hm@oiom@Άa@m@$Hmq{m@ham@@ m@Gn@n@ڶm@@X!m@d%ѕm@m@p m@A .mm@1>Zm@fBtm@'$Rm@mz>m@23m@Pg#n@En@VU{gn@gl[…n@n@pcn@rEvn@v0cn@⋴cSn@ׯ@n@C0n@#n@in@pQbn@1s m@5Sm@}lEm@]n@= ֬ n@Z1m@Fm@FJaFm@ԏm@uF{m@6,m@?m@a.m@-nm@'dKm@jȂm@ݠm@۶/m@|K(m@7&&n@W7n@zz:n@(q-n@HMln@Yn@.B"m@*)n@?Я70n@ܔ_n@9%}rn@ĸhn@ven@ɂwn@Tn@HLn@po@#m,]o@IB o@N$pp@Z0-p@j*@p@ */8p@#p@Y-/$p@⼓ p@&Bp@Lp@dp@jJqR p@ p@{Fp@ "#p@tp|p@sC p@P8p@\̘p@Np@՝[o@-HZcYo@>, aEo@ko@n@Za5m@m 4m@x:*Km@( 8n@͟cm@[ m@^"m@gGm@h^=pm@@m@SHl@Tfgl@6hZgl@ ;RRl@?}[l@`al@Tl@%Yؒl@3hׁOl@""l@.Del@E|Wl@{s8l@_(l@Nl@/]el@(fm@`A\m@ĩ4Om@'6ބm@&-n@02n@FQ>T n@ё9m@:m@CU֠m@*J1m@2fm@_3:m@w14m@ªxPm@a6m@@Qm@m@ n@*/;/n@Q#DIn@=r3Gn@ȧ76n@1,n@{B/n@3C4n@4m@iu|m@n@;n@9˃8n@ͪm@[H4n@7rIn@/!,n@E n@U{m@ 'm@QԼm@jKf"m@ZԨm@= _m@u~Vm@st1m@rm@!=1m@/4o|m@m@6|8m@|q]n@ إn@=4n@ #En@d|Ln@MdCn@x 9n@yi}4n@BR2n@j:@Gn@($}nn@85Tan@jsn@{yצhn@S;މ`n@_[n@۞n@AJ9n@ +o@SDBo@(o@#^o@/o@̓Po@ޚo@ho@Ho@xo@\Gp@[N p@pUXp@*s#Ko@W N^o@ ICp@ 6^p@ 0p@uMTp@ ;p@K p@Mo@( V>o@Yܪn@z䘗n@/n@un@*n@cem@glm@ `m@r#?Dl@)l@X+m@l;cm@G*m@DB"m@GI/l@$l@ cGl@:G n@!w5n@ә,n@7eGn@hUn@s]n@YJZn@ Ln@?7n@,97n@+%n@.V)r)n@y>Cn@WMW(=n@+0n@^2Dn@$sn@hn@ZOr n@!W:_ o@P'r1!o@uj 'o@*=o@ͷ:#o@mo@SrR p@0p@U p@ o@FG!o@ o@0p@܋p@X/p@6p@ %p@Fgvo@ o@=n@fatn@6\.4n@=^2n@(v&n@ AQjn@3_tm@SkEsm@o{)m@c\m@cim@gR"m@i9Um@`#m@X"Yl@{Kl@LPm@%-m@>l@Y l@bl@}3+-l@ÿ[l@.l@ wm@J_m@l|>n@z]\n@o@1Ho@i} ֧o@zo@KlԶo@ma$p@أAp@YXOVeHp@1Ap@n,p@U)ro@3eLo@V0gn@Nnn@Dn@/n@un@H^n@gn@Jn@$Om@p.m@ټxtl@E l@k~:Fm@ YVYm@H!m@T>l@51l@.GMJm@hnvm@4BhSm@۵Q[(m@BQ4m@om@D=m@ lcm@fA%n@^f.n@>vG[ n@8um@ m@xzm@K8m@<;Pm@\ m@ntwm@@|^m@h0fm@MCxsm@ gm@AoHm@/$1m@cJm@DI>m@/?Am@DcuZm@7rm@8m@l!Om@Pkݟm@m@xm@@[m@!NMm@TOm@m[Rm@bZӝUm@AyZXm@Om@*>2Im@1>\Ym@y?pbjm@xu{[lm@1Oym@Ek?elm@.MHm@wc0m@[[m@9m@{Qzn@E'#n@$Jn@Vtn@h߿n@vin@jn@}Vn@^bo@*]o@D3؛o@L ko@tm@TRi]m@3`pm@"rkm@mTym@efm@wİm@ slm@#Jm@eR! m@um@R+Λm@@m@/J"a/um@,hm@r,vpm@ b!~m@m@αBm@ӆm@P*m@LD/m@+gR;m@Ԉ%ͫm@2僷m@| m@ΎU1m@_sn@l<&n@]1Tl#n@rin@Q +n@pn@&dn@RLOo@޴3zo@܈HwCao@&-o@tST7o@%Y3o@ڿnqto@/`po@e6o@FZ|o@AOo@Gso@ n@ 0U/Nn@'n@щn@}ipn@ Pn@$<(p%n@%e(m@ @m@# m@{ԲBm@i,m@fu7m@;(m@^Gzum@(51m@! n@E}~n@L`m@Cm@Zem@kwHgm@n j;m@cm@5md|n@,?+ n@U:n@ ]uCFn@I"6n@mM n@`m@Pm@km@im@x“m@aқm@@Im@dTm@_(m@Pm@Y@m@رxm@ܹaRm@@[Ϻm@Gm@f`ճm@ m@2Jm@mm@Aq1In@GG92n@gwLn@`>n@PAm@ >m@r1mm@qm@.m@ACn@W$(n@%Yn@֤U+n@Xn@hbwn@Fo@S|4o@M`)A3o@l+ o@jAn@=ݳn@hY.,Tn@VBn@m5w5n@:X^9n@('_bn@&{n@Mn@k?lln@ p5n@0I[n@}on@ppn@4dvgn@v9\n@rOLւn@[Ukn@FOn@An@]Δ3n@{RⲢn@Z}n@\n@8Bn@S4f3n@mJ9n@ 㲇Fn@Jn@In@[vCYn@L'n@rWn@jn@?<Nn@e<(6Tn@).n@| n@66fn@OUGn@Yy*n@K@Un@jm@5(m@s6n@_S;Ukn@gn@5g֎n@T=r)J+n@O]&n@ +n@"筽Xn@315m@>Dm@h gm@D@E m@Arn@T-gEn@Gpn@2' n@_n@'vLt_n@On@jӘҲn@UOn@뀀n@6Zin@жn@m@n@B%wn@y~n@SIGn@y٤!n@Un@ n@dKn@VUsn@Jn@m@i]m@]m@yn@!n@-%pCn@6`fn@62n@*Μn@ 5n@UMn@\.'Pn@Tln@}*Cn@"D'#n@&bn@ectrans-1.8.0/tests/test_ectrans4py/data/zonal_wavenumbers.npy0000664000175000017500000000246015174631767025065 0ustar alastairalastairNUMPYv{'descr': '= WORLD_NUM_RANKS) THEN PRINT*, "SPLIT = ", SPLIT_NUM_RANKS, "TOTAL = ", WORLD_NUM_RANKS CALL ABORT_TRANS("ERROR: SPLIT COMMUNICATOR NOT SMALLER THAN MPI_COMM_WORLD.") END IF PRINT*,"=== LOCAL RANK ", SPLIT_RANK, ", ON GROUP", SPLIT_COLOUR, "SIZE", SPLIT_NUM_RANKS, "===" CALL SETUP_TRANS0(KPRINTLEV=0, LDMPOFF=.FALSE., & ! SPLIT GRID NS SPLIT SPECTRAL KPRGPNS=SPLIT_NUM_RANKS, KPRTRW=SPLIT_NUM_RANKS) ! Different transform based on the colour. TRUNCATION = TRUNCATIONS(SPLIT_COLOUR + 1) NUM_LATITUDES = 2*(TRUNCATION + 1) NUM_LONGITUDES = NUM_LATITUDES*2 IF (SPLIT_RANK == 1) PRINT*,"COLOUR ", SPLIT_COLOUR, & " GLOBAL NUM LON =>", NUM_LONGITUDES, "| LAT =>", NUM_LATITUDES CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NUM_LATITUDES) ! Get function space sizes CALL TRANS_INQ(KSPEC2=NUM_SPECTRAL_ELEMENTS, KGPTOT=NUM_GRID_POINTS) CALL TRANS_INQ(KSPEC2G=G_NUM_SPECTRAL_ELEMENTS, KGPTOTG=G_NUM_GRID_POINTS) ALLOCATE(SPECTRAL_FIELD(1, NUM_SPECTRAL_ELEMENTS)) ALLOCATE(GRID_POINT_FIELD(NUM_GRID_POINTS, 1, 1)) ! Get spectral indices ALLOCATE(SPECTRAL_INDICES(0:TRUNCATION)) CALL TRANS_INQ(KASM0=SPECTRAL_INDICES) ! Select mode M = MS(SPLIT_COLOUR + 1) N = NS(SPLIT_COLOUR + 1) LOCAL_SPECTRAL_COEFFICIENT_INDEX = SPECTRAL_INDICES(M) + 2*(N - M) + 1 SPECTRAL_FIELD(:,:) = 0.0 IF (LOCAL_SPECTRAL_COEFFICIENT_INDEX > 0) THEN SPECTRAL_FIELD(1,LOCAL_SPECTRAL_COEFFICIENT_INDEX) = 1.0 END IF CALL INV_TRANS(PSPSCALAR=SPECTRAL_FIELD, PGP=GRID_POINT_FIELD) ! -------------- Gather the result on the root (0) and write to file ----------------- IF (SPLIT_RANK == 1) THEN ! Allocate a global field. ALLOCATE(G_GRID_POINT_FIELD(G_NUM_GRID_POINTS,1)) CALL GATH_GRID(PGPG=G_GRID_POINT_FIELD, KFGATHG=1, KTO=[1], PGP=GRID_POINT_FIELD) ! Write to file. can then be plotted using a python script ! Such as in the docs: https://sites.ecmwf.int/docs/ectrans/page/usage.html. WRITE(FILENAME, "(A,I0,A4)") "grid_point_field_trunc_", TRUNCATION, ".dat" OPEN(7, FILE=FILENAME, FORM="unformatted") WRITE(7) G_GRID_POINT_FIELD(:,1) CLOSE(7) PRINT*,"Colour", SPLIT_COLOUR, "finished and written to file: "//TRIM(FILENAME) ELSE CALL GATH_GRID(KFGATHG=1, KTO=[1], PGP=GRID_POINT_FIELD) END IF CALL MPL_END() CONTAINS ! Get the colour of comm for this rank. FUNCTION GET_SPLIT_GROUP(RANK, WORLD_SIZE) RESULT(GROUP) IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: RANK INTEGER(KIND=JPIM), INTENT(IN) :: WORLD_SIZE ! RETURN INTEGER(KIND=JPIM) :: GROUP REAL(KIND=JPRB) :: RANK_RATIO ! ---------------------------------------------- ! Uneven splitting based on a ratio 1:3. ! ---------------------------------------------- RANK_RATIO = REAL(RANK, KIND=JPRB) / REAL(WORLD_SIZE, KIND=JPRB) ! Split X% IF (RANK_RATIO <= 0.25_JPRB) THEN GROUP = 0 ELSE GROUP = 1 END IF END FUNCTION GET_SPLIT_GROUP END PROGRAM ectrans-1.8.0/tests/trans/adjoint/0000775000175000017500000000000015174631767017305 5ustar alastairalastairectrans-1.8.0/tests/trans/adjoint/test_invtrans_adjoint.F900000664000175000017500000002053715174631767024207 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! 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. ! ================================================================================================== ! INV_TRANS adjoint test ! ================================================================================================== ! ! This program performs a rudimentary check of tangent-linear/adjoint correspondence of ! INV_TRANS and INV_TRANSAD. ! ! The program checks the correspondence of and ! which with infinite precision should match exactly. In practice there is some divergence due to ! rounding errors. In this program we check whether the two expressions are the same to within a ! tolerance of 20000 * machine epsilon. ! ! In this test X1, the "global state vector", is comprised of scalar, vorticity and divergence ! defined on 9 model levels. The correspondence is computed across the whole state vector. ! ! ================================================================================================== PROGRAM TEST_INVTRANS_ADJOINT USE PARKIND1, ONLY: JPIM, JPRB USE MPL_MODULE, ONLY: MPL_INIT, MPL_MYRANK, MPL_NPROC, MPL_BARRIER, MPL_END USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE UTILS, ONLY: DETECT_MPIRUN, SCALPRODSP, SCALPRODGP IMPLICIT NONE INTEGER(KIND=JPIM), PARAMETER :: JPTRUNCATION = 159 ! T159 spectral resolution INTEGER(KIND=JPIM), PARAMETER :: JPPROMA = 16 INTEGER(KIND=JPIM), PARAMETER :: JP_NUMLEVELS_G = 9 INTEGER(KIND=JPIM), PARAMETER :: JPNLAT = 2 * (JPTRUNCATION + 1) INTEGER(KIND=JPIM) :: INPROC, IMYPROC, IPRGPNS, IPRGPEW, IPRTRW, IPRTRV, IGPTOTG, IGPTOT, IGPBLKS INTEGER(KIND=JPIM) :: ISPEC2G, ISPEC2 INTEGER(KIND=JPIM) :: INUM_LEVELS INTEGER(KIND=JPIM) :: IMYSETV INTEGER(KIND=JPIM) :: IVSET(JP_NUMLEVELS_G) INTEGER(KIND=JPIM) :: NLOEN(JPNLAT) INTEGER(KIND=JPIM) :: ITOSP(JP_NUMLEVELS_G), ITOGP(3*JP_NUMLEVELS_G) INTEGER(KIND=JPIM) :: JLEV, JA, JB LOGICAL :: LLUSE_MPI INTEGER(KIND=JPIM) :: IOUT = 6, IERR = 0 ! STDOUT and STDERR REAL(KIND=JPRB) , ALLOCATABLE :: ZSPECX(:,:), ZSPECY(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZVORX(:,:), ZVORY(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZDIVX(:,:), ZDIVY(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZGX(:,:,:), ZGY(:,:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZSPECXG(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZVORXG(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZDIVXG(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZGXG(:,:) REAL(KIND=JPRB) :: ADJ_VALUE_1 REAL(KIND=JPRB) :: ADJ_VALUE_2 REAL(KIND=JPRB) :: ZRELATIVE_ERROR INTEGER(KIND=JPIM) :: N INTEGER(KIND=JPIM), ALLOCATABLE :: SEED(:) #include "setup_trans0.h" #include "setup_trans.h" #include "trans_inq.h" #include "inv_trans.h" #include "inv_transad.h" #include "dist_grid.h" #include "dist_spec.h" #include "trans_end.h" ! Fix random number seed CALL RANDOM_SEED(SIZE=N) ALLOCATE(SEED(N)) SEED(:) = 1 CALL RANDOM_SEED(PUT=SEED) LLUSE_MPI = DETECT_MPIRUN() ! Set up MPI IF (LLUSE_MPI) THEN CALL MPL_INIT IMYPROC = MPL_MYRANK() INPROC = MPL_NPROC() ELSE IMYPROC = 1 INPROC = 1 ENDIF ! Only output to stdout on first task IF (INPROC > 1) THEN IF (IMYPROC /= 1) THEN OPEN(UNIT=IOUT, FILE='/dev/null') ENDIF ENDIF ! Compute E-W and V-W set sizes DO JA = INT(SQRT(REAL(INPROC,JPRB))), INPROC JB = INPROC / JA IF (JA * JB == INPROC) THEN IPRGPNS = MAX(JA, JB) IPRGPEW = MIN(JA, JB) IPRTRW = MAX(JA, JB) IPRTRV = MIN(JA, JB) ENDIF ENDDO IMYSETV = MOD(IMYPROC - 1, IPRTRV) + 1 ! Use a full Gaussian grid NLOEN(:) = 2*JPNLAT ! Initialise ecTrans CALL SETUP_TRANS0(KOUT=IOUT, KERR=IERR, KPRGPNS=IPRGPNS, KPRGPEW=IPRGPEW, KPRTRW=IPRTRW, & & LDMPOFF=.NOT. LLUSE_MPI, KPRINTLEV=0) CALL SETUP_TRANS(KSMAX=JPTRUNCATION, KDGL=JPNLAT, KLOEN=NLOEN, LDSPLIT=.TRUE.) CALL TRANS_INQ(KSPEC2=ISPEC2, KSPEC2G=ISPEC2G, KGPTOT=IGPTOT, KGPTOTG=IGPTOTG) IGPBLKS = (IGPTOT-1)/JPPROMA+1 ! Determine number of local levels INUM_LEVELS = 0 DO JLEV = 1, JP_NUMLEVELS_G IVSET(JLEV) = MOD(JLEV, IPRTRV) + 1 IF (IVSET(JLEV) == IMYSETV) THEN INUM_LEVELS = INUM_LEVELS + 1 ENDIF ENDDO ! Initially task 1 has all the fields ITOSP(:) = 1 ITOGP(:) = 1 ! ===== Allocate and initialize spectral data ===== ALLOCATE(ZSPECXG(JP_NUMLEVELS_G,ISPEC2G)) ALLOCATE(ZVORXG(JP_NUMLEVELS_G,ISPEC2G)) ALLOCATE(ZDIVXG(JP_NUMLEVELS_G,ISPEC2G)) ALLOCATE(ZSPECX(INUM_LEVELS,ISPEC2)) ALLOCATE(ZSPECY(INUM_LEVELS,ISPEC2)) ALLOCATE(ZVORX(INUM_LEVELS,ISPEC2)) ALLOCATE(ZVORY(INUM_LEVELS,ISPEC2)) ALLOCATE(ZDIVX(INUM_LEVELS,ISPEC2)) ALLOCATE(ZDIVY(INUM_LEVELS,ISPEC2)) IF (IMYPROC == 1) THEN CALL RANDOM_NUMBER(ZSPECXG) ZSPECXG(:,:) = 0.1_JPRB * (1.0_JPRB - 2.0_JPRB * ZSPECXG(:,:)) CALL RANDOM_NUMBER(ZVORXG) ZVORXG(:,:) = 0.1_JPRB * (1.0_JPRB - 2.0_JPRB * ZVORXG(:,:)) CALL RANDOM_NUMBER(ZDIVXG) ZDIVXG(:,:) = 0.1_JPRB * (1.0_JPRB - 2.0_JPRB * ZDIVXG(:,:)) ENDIF CALL DIST_SPEC(PSPECG=ZSPECXG, KFDISTG=JP_NUMLEVELS_G, KFROM=ITOSP, PSPEC=ZSPECX, KVSET=IVSET) CALL DIST_SPEC(PSPECG=ZVORXG, KFDISTG=JP_NUMLEVELS_G, KFROM=ITOSP, PSPEC=ZVORX, KVSET=IVSET) CALL DIST_SPEC(PSPECG=ZDIVXG, KFDISTG=JP_NUMLEVELS_G, KFROM=ITOSP, PSPEC=ZDIVX, KVSET=IVSET) ! ===== Allocate and initialize gridpoint data ===== ALLOCATE(ZGXG(IGPTOTG,3*JP_NUMLEVELS_G)) ALLOCATE(ZGX(JPPROMA,3*JP_NUMLEVELS_G,IGPBLKS)) ALLOCATE(ZGY(JPPROMA,3*JP_NUMLEVELS_G,IGPBLKS)) IF (IMYPROC == 1) THEN CALL RANDOM_NUMBER(ZGXG) ZGXG(:,:) = (1.0_JPRB-2.0_JPRB*ZGXG(:,:)) ENDIF CALL DIST_GRID(PGPG=ZGXG, KFDISTG=3*JP_NUMLEVELS_G, KFROM=ITOGP, PGP=ZGX, KPROMA=JPPROMA) ! ===== Compute invtrans and gather result on proc 1 ===== ! i.e. invtrans(rspscalarx, rspvorx, rspdivx) = rgpy CALL INV_TRANS(PSPSCALAR=ZSPECX, PSPVOR=ZVORX, PSPDIV=ZDIVX, PGP=ZGY, KPROMA=JPPROMA, & & KVSETSC=IVSET, KVSETUV=IVSET) ! ===== Compute: adj_value2 = ===== ! i.e. adj_value2 = ADJ_VALUE_1 = SCALPRODGP(ZGY, ZGX, JPPROMA, 3 * JP_NUMLEVELS_G, IGPBLKS, IGPTOT, IGPTOTG, IMYPROC) ! ===== Compute adjoint invtrans and gather result on proc 1 ===== ! i.e. invtrans_adj(rgpx) = (rspscalary, rspvory, rspdivy) ! Zero output arrays ! This shouldn't be necessary as these are passed to INTENT(OUT) arguments ! However in PRFI1BAD we actually append to these arrays so we assume they ! are initialised (rightly or wrongly...) ZSPECY(:,:) = 0.0_JPRB ZVORY(:,:) = 0.0_JPRB ZDIVY(:,:) = 0.0_JPRB CALL INV_TRANSAD(PSPSCALAR=ZSPECY, PSPVOR=ZVORY, PSPDIV=ZDIVY, PGP=ZGX, KPROMA=JPPROMA, & & KVSETSC=IVSET, KVSETUV=IVSET) ! ===== Compute: adj_value1 = <(rspscalarx, rspvorx, rspdivx), invtrans_adj(rgpx)> ===== ! i.e. adj_value1 = <(rspscalary, rspvory, rspdivy), (rspscalarx, rspvorx, rspdivx)> ADJ_VALUE_2 = SCALPRODSP(ZSPECX, ZSPECY, IVSET, INUM_LEVELS, JP_NUMLEVELS_G, ISPEC2, ISPEC2G, JPTRUNCATION, IMYPROC) + & & SCALPRODSP(ZVORX, ZVORY, IVSET, INUM_LEVELS, JP_NUMLEVELS_G, ISPEC2, ISPEC2G, JPTRUNCATION, IMYPROC) + & & SCALPRODSP(ZDIVX, ZDIVY, IVSET, INUM_LEVELS, JP_NUMLEVELS_G, ISPEC2, ISPEC2G, JPTRUNCATION, IMYPROC) ! Only task 1 should perform the correctness check IF (IMYPROC == 1) THEN ! ===== Compare inner products ===== ! i.e. == ZRELATIVE_ERROR = ABS(ADJ_VALUE_1 - ADJ_VALUE_2) / ABS(ADJ_VALUE_1) WRITE(IOUT, '(A,1E30.15)') ' = ', ADJ_VALUE_1 WRITE(IOUT, '(A,1E30.15)') ' = ', ADJ_VALUE_2 WRITE(IOUT, '(A,1E20.15)') 'Relative error = ', ZRELATIVE_ERROR ! Abort if relative error is > 20000 * machine epsilon ! All tested compilers seem to be happy with a threshold of 20000, though it is a bit arbitrary IF (ZRELATIVE_ERROR > 20000.0*EPSILON(1.0_JPRB)) THEN WRITE(IOUT, '(A)') '*******************************' WRITE(IOUT, '(A)') 'Adjoint test failed' WRITE(IOUT, '(A)') 'Relative error greater than 20000 * machine epsilon' WRITE(IOUT, '(1E20.15,A3,1E20.15)') ZRELATIVE_ERROR, ' > ', 20000.0*EPSILON(1.0_JPRB) WRITE(IOUT, '(A)') '*******************************' FLUSH(IOUT) CALL TRANS_END CALL ABORT_TRANS("Adjoint test failed") ENDIF ENDIF CALL TRANS_END IF (LLUSE_MPI) THEN CALL MPL_BARRIER() CALL MPL_END ENDIF END PROGRAM TEST_INVTRANS_ADJOINT ectrans-1.8.0/tests/trans/adjoint/test_dirtrans_adjoint.F900000664000175000017500000002010215174631767024155 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! 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. ! ================================================================================================== ! DIR_TRANS adjoint test ! ================================================================================================== ! ! This program performs a rudimentary check of tangent-linear/adjoint correspondence of ! DIR_TRANS and DIR_TRANSAD. ! ! The program checks the correspondence of and ! which with infinite precision should match exactly. In practice there is some divergence due to ! rounding errors. In this program we check whether the two expressions are the same to within a ! tolerance of 20000 * machine epsilon. ! ! In this test X1, the "global state vector", is comprised of scalar, and u-v fields ! defined on 9 model levels. The correspondence is computed across the whole state vector. ! ! ================================================================================================== PROGRAM TEST_DIRTRANS_ADJOINT USE PARKIND1, ONLY: JPIM, JPRB USE MPL_MODULE, ONLY: MPL_INIT, MPL_MYRANK, MPL_NPROC, MPL_BARRIER, MPL_END USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE UTILS, ONLY: DETECT_MPIRUN, SCALPRODSP, SCALPRODGP IMPLICIT NONE INTEGER(KIND=JPIM), PARAMETER :: JPTRUNCATION = 159 ! T159 spectral resolution INTEGER(KIND=JPIM), PARAMETER :: JPPROMA = 16 INTEGER(KIND=JPIM), PARAMETER :: JP_NUMLEVELS_G = 9 INTEGER(KIND=JPIM), PARAMETER :: JPNLAT = 2 * (JPTRUNCATION + 1) INTEGER(KIND=JPIM) :: INPROC, IMYPROC, IPRGPNS, IPRGPEW, IPRTRW, IPRTRV, IGPTOTG, IGPTOT, IGPBLKS INTEGER(KIND=JPIM) :: ISPEC2G, ISPEC2 INTEGER(KIND=JPIM) :: INUM_LEVELS INTEGER(KIND=JPIM) :: IMYSETV INTEGER(KIND=JPIM) :: IVSET(JP_NUMLEVELS_G) INTEGER(KIND=JPIM) :: NLOEN(JPNLAT) INTEGER(KIND=JPIM) :: ITOSP(JP_NUMLEVELS_G), ITOGP(3*JP_NUMLEVELS_G) INTEGER(KIND=JPIM) :: JLEV, JA, JB LOGICAL :: LLUSE_MPI INTEGER(KIND=JPIM) :: IOUT = 6, IERR = 0 ! STDOUT and STDERR REAL(KIND=JPRB) , ALLOCATABLE :: ZSPECX(:,:), ZSPECY(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZVORX(:,:), ZVORY(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZDIVX(:,:), ZDIVY(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZGX(:,:,:), ZGY(:,:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZSPECXG(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZVORXG(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZDIVXG(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZGXG(:,:) REAL(KIND=JPRB) :: ADJ_VALUE_1 REAL(KIND=JPRB) :: ADJ_VALUE_2 REAL(KIND=JPRB) :: ZRELATIVE_ERROR INTEGER(KIND=JPIM) :: N INTEGER(KIND=JPIM), ALLOCATABLE :: SEED(:) #include "setup_trans0.h" #include "setup_trans.h" #include "trans_inq.h" #include "dir_trans.h" #include "dir_transad.h" #include "dist_grid.h" #include "dist_spec.h" #include "trans_end.h" ! Fix random number seed CALL RANDOM_SEED(SIZE=N) ALLOCATE(SEED(N)) SEED(:) = 1 CALL RANDOM_SEED(PUT=SEED) LLUSE_MPI = DETECT_MPIRUN() ! Set up MPI IF (LLUSE_MPI) THEN CALL MPL_INIT IMYPROC = MPL_MYRANK() INPROC = MPL_NPROC() ELSE IMYPROC = 1 INPROC = 1 ENDIF ! Only output to stdout on first task IF (INPROC > 1) THEN IF (IMYPROC /= 1) THEN OPEN(UNIT=IOUT, FILE='/dev/null') ENDIF ENDIF ! Compute E-W and V-W set sizes DO JA = INT(SQRT(REAL(INPROC,JPRB))), INPROC JB = INPROC / JA IF (JA * JB == INPROC) THEN IPRGPNS = MAX(JA, JB) IPRGPEW = MIN(JA, JB) IPRTRW = MAX(JA, JB) IPRTRV = MIN(JA, JB) ENDIF ENDDO IMYSETV = MOD(IMYPROC - 1, IPRTRV) + 1 ! Use a full Gaussian grid NLOEN(:) = 2*JPNLAT ! Initialise ecTrans CALL SETUP_TRANS0(KOUT=IOUT, KERR=IERR, KPRGPNS=IPRGPNS, KPRGPEW=IPRGPEW, KPRTRW=IPRTRW, & & LDMPOFF=.NOT. LLUSE_MPI, KPRINTLEV=0) CALL SETUP_TRANS(KSMAX=JPTRUNCATION, KDGL=JPNLAT, KLOEN=NLOEN, LDSPLIT=.TRUE.) CALL TRANS_INQ(KSPEC2=ISPEC2, KSPEC2G=ISPEC2G, KGPTOT=IGPTOT, KGPTOTG=IGPTOTG) IGPBLKS = (IGPTOT-1)/JPPROMA+1 ! Determine number of local levels INUM_LEVELS = 0 DO JLEV = 1, JP_NUMLEVELS_G IVSET(JLEV) = MOD(JLEV, IPRTRV) + 1 IF (IVSET(JLEV) == IMYSETV) THEN INUM_LEVELS = INUM_LEVELS + 1 ENDIF ENDDO ! Initially task 1 has all the fields ITOSP(:) = 1 ITOGP(:) = 1 ! ===== Allocate and initialize spectral data ===== ALLOCATE(ZSPECXG(JP_NUMLEVELS_G,ISPEC2G)) ALLOCATE(ZVORXG(JP_NUMLEVELS_G,ISPEC2G)) ALLOCATE(ZDIVXG(JP_NUMLEVELS_G,ISPEC2G)) ALLOCATE(ZSPECX(INUM_LEVELS,ISPEC2)) ALLOCATE(ZSPECY(INUM_LEVELS,ISPEC2)) ALLOCATE(ZVORX(INUM_LEVELS,ISPEC2)) ALLOCATE(ZVORY(INUM_LEVELS,ISPEC2)) ALLOCATE(ZDIVX(INUM_LEVELS,ISPEC2)) ALLOCATE(ZDIVY(INUM_LEVELS,ISPEC2)) IF (IMYPROC == 1) THEN CALL RANDOM_NUMBER(ZSPECXG) ZSPECXG(:,:) = 0.1_JPRB * (1.0_JPRB - 2.0_JPRB * ZSPECXG(:,:)) CALL RANDOM_NUMBER(ZVORXG) ZVORXG(:,:) = 0.1_JPRB * (1.0_JPRB - 2.0_JPRB * ZVORXG(:,:)) CALL RANDOM_NUMBER(ZDIVXG) ZDIVXG(:,:) = 0.1_JPRB * (1.0_JPRB - 2.0_JPRB * ZDIVXG(:,:)) ENDIF CALL DIST_SPEC(PSPECG=ZSPECXG, KFDISTG=JP_NUMLEVELS_G, KFROM=ITOSP, PSPEC=ZSPECX, KVSET=IVSET) CALL DIST_SPEC(PSPECG=ZVORXG, KFDISTG=JP_NUMLEVELS_G, KFROM=ITOSP, PSPEC=ZVORX, KVSET=IVSET) CALL DIST_SPEC(PSPECG=ZDIVXG, KFDISTG=JP_NUMLEVELS_G, KFROM=ITOSP, PSPEC=ZDIVX, KVSET=IVSET) ! ===== Allocate and initialize gridpoint data ===== ALLOCATE(ZGXG(IGPTOTG,3*JP_NUMLEVELS_G)) ALLOCATE(ZGX(JPPROMA,3*JP_NUMLEVELS_G,IGPBLKS)) ALLOCATE(ZGY(JPPROMA,3*JP_NUMLEVELS_G,IGPBLKS)) IF (IMYPROC == 1) THEN CALL RANDOM_NUMBER(ZGXG) ZGXG(:,:) = (1.0_JPRB-2.0_JPRB*ZGXG(:,:)) ENDIF CALL DIST_GRID(PGPG=ZGXG, KFDISTG=3*JP_NUMLEVELS_G, KFROM=ITOGP, PGP=ZGX, KPROMA=JPPROMA) ! ===== Compute adjoint dirtrans and gather result on proc 1 ===== ! i.e. dirtrans(rgpx) = (rspscalary, rspvory, rspdivy) CALL DIR_TRANS(PSPSCALAR=ZSPECY, PSPVOR=ZVORY, PSPDIV=ZDIVY, PGP=ZGX, KPROMA=JPPROMA, & & KVSETSC=IVSET, KVSETUV=IVSET) ! ===== Compute: adj_value1 = ===== ! i.e. adj_value1 = <(rspscalary, rspvory, rspdivy), (rspscalarx, rspvorx, rspdivx)> ADJ_VALUE_1 = SCALPRODSP(ZSPECX, ZSPECY, IVSET, INUM_LEVELS, JP_NUMLEVELS_G, ISPEC2, ISPEC2G, JPTRUNCATION, IMYPROC) + & & SCALPRODSP(ZVORX, ZVORY, IVSET, INUM_LEVELS, JP_NUMLEVELS_G, ISPEC2, ISPEC2G, JPTRUNCATION, IMYPROC ) + & & SCALPRODSP(ZDIVX, ZDIVY, IVSET, INUM_LEVELS, JP_NUMLEVELS_G, ISPEC2, ISPEC2G, JPTRUNCATION, IMYPROC) ! ===== Compute dirtrans_adj and gather result on proc 1 ===== ! i.e. dirtrans_adj(rspscalarx, rspvorx, rspdivx) = rgpy CALL DIR_TRANSAD(PSPSCALAR=ZSPECX, PSPVOR=ZVORX, PSPDIV=ZDIVX, PGP=ZGY, KPROMA=JPPROMA, & & KVSETSC=IVSET, KVSETUV=IVSET) ! ===== Compute: adj_value2 = ===== ! i.e. adj_value2 = ADJ_VALUE_2 = SCALPRODGP(ZGY, ZGX, JPPROMA, 3 * JP_NUMLEVELS_G, IGPBLKS, IGPTOT, IGPTOTG, IMYPROC) ! Only task 1 should perform the correctness check IF (IMYPROC == 1) THEN ! ===== Compare inner products ===== ! i.e. == ZRELATIVE_ERROR = ABS(ADJ_VALUE_1 - ADJ_VALUE_2) / ABS(ADJ_VALUE_1) WRITE(IOUT, '(A,1E30.15)') ' = ', ADJ_VALUE_1 WRITE(IOUT, '(A,1E30.15)') ' = ', ADJ_VALUE_2 WRITE(IOUT, '(A,1E20.15)') 'Relative error = ', ZRELATIVE_ERROR ! Abort if relative error is > 20000 * machine epsilon ! All tested compilers seem to be happy with a threshold of 20000, thought it is a bit arbitrary IF (ZRELATIVE_ERROR > 20000.0*EPSILON(1.0_JPRB)) THEN WRITE(IOUT, '(A)') '*******************************' WRITE(IOUT, '(A)') 'Adjoint test failed' WRITE(IOUT, '(A)') 'Relative error greater than 20000 * machine epsilon' WRITE(IOUT, '(1E20.15,A3,1E20.15)') ZRELATIVE_ERROR, ' > ', 20000.0*EPSILON(1.0_JPRB) WRITE(IOUT, '(A)') '*******************************' FLUSH(IOUT) CALL TRANS_END CALL ABORT_TRANS("Adjoint test failed") ENDIF ENDIF CALL TRANS_END IF (LLUSE_MPI) THEN CALL MPL_BARRIER() CALL MPL_END ENDIF END PROGRAM TEST_DIRTRANS_ADJOINT ectrans-1.8.0/tests/trans/adjoint/test_gpnorm_adjoint.F900000664000175000017500000001366215174631767023646 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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. ! ================================================================================================== ! GPNORM_TRANS adjoint test ! ================================================================================================== ! ! This program performs a rudimentary check of tangent-linear/adjoint correspondence of ! GPNORM_TRANSTL and GPNORM_TRANSAD. ! ! The program checks the correspondence of and ! which with infinite precision should match exactly. In practice there is some divergence due to ! rounding errors. In this program we check whether the two expressions are the same to within a ! tolerance of 5000 * machine epsilon. ! ! The check is performed for a grid point array with 10 fields at TCO159 with a block size of 16. ! ! ================================================================================================== PROGRAM TEST_GPNORM_TRANS_ADJOINT USE PARKIND1, ONLY: JPIM, JPRB, JPRD USE MPL_MODULE, ONLY: MPL_INIT, MPL_MYRANK, MPL_NPROC, MPL_BARRIER, MPL_END USE TPM_FIELDS, ONLY: F USE TPM_GEOMETRY, ONLY: G USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS use UTILS, ONLY: DETECT_MPIRUN IMPLICIT NONE INTEGER(KIND=JPIM), PARAMETER :: JPTRUNCATION = 159 ! T159 spectral resolution INTEGER(KIND=JPIM), PARAMETER :: JPPROMA = 16 INTEGER(KIND=JPIM), PARAMETER :: JPNUM_FIELDS = 10 INTEGER(KIND=JPIM), PARAMETER :: JPNLAT = 2 * (JPTRUNCATION + 1) INTEGER(KIND=JPIM) :: INPROC, IMYPROC, IPRGPNS, IPRGPEW, IPRTRW, IPRTRV, IGPTOTG, IGPTOT, IGPBLKS REAL(KIND=JPRB), ALLOCATABLE :: ZX1(:,:,:), ZX2(:,:,:) REAL(KIND=JPRB) :: ZY1(JPNUM_FIELDS), ZY2(JPNUM_FIELDS) REAL(KIND=JPRB), ALLOCATABLE :: ZPRODUCT(:,:,:) REAL(KIND=JPRB) :: ZPRODUCT_AVE(JPNUM_FIELDS) INTEGER(KIND=JPIM) :: NLOEN(JPNLAT) ! These are not actually used, but they must be passed to GPNORM_TRANS/GPNORM_TRANSAD anyway REAL(KIND=JPRB) :: ZMIN_DUMMY(JPNUM_FIELDS), ZMAX_DUMMY(JPNUM_FIELDS) LOGICAL :: LLUSE_MPI INTEGER(KIND=JPIM) :: IOUT = 6, IERR = 0 ! STDOUT and STDERR INTEGER(KIND=JPIM) :: JA, JB, JL, JP, JF, JBLK REAL(KIND=JPRB) :: ZRAND REAL(KIND=JPRB) :: ZLHS, ZRHS, ZRELATIVE_ERROR INTEGER(KIND=JPIM) :: N INTEGER(KIND=JPIM), ALLOCATABLE :: SEED(:) #include "setup_trans0.h" #include "setup_trans.h" #include "trans_inq.h" #include "gpnorm_transtl.h" #include "gpnorm_transad.h" #include "gpnorm_trans.h" #include "trans_end.h" ! Fix random number seed CALL RANDOM_SEED(SIZE=N) ALLOCATE(SEED(N)) SEED(:) = 1 CALL RANDOM_SEED(PUT=SEED) LLUSE_MPI = DETECT_MPIRUN() ! Set up MPI IF (LLUSE_MPI) THEN CALL MPL_INIT IMYPROC = MPL_MYRANK() INPROC = MPL_NPROC() ELSE IMYPROC = 1 INPROC = 1 ENDIF ! Only output to stdout on first task IF (INPROC > 1) THEN IF (IMYPROC /= 1) THEN OPEN(UNIT=IOUT, FILE='/dev/null') ENDIF ENDIF ! Compute E-W and V-W set sizes DO JA = INT(SQRT(REAL(INPROC,JPRB))), INPROC JB = INPROC / JA IF (JA * JB == INPROC) THEN IPRGPNS = MAX(JA, JB) IPRGPEW = MIN(JA, JB) IPRTRW = MAX(JA, JB) IPRTRV = MIN(JA, JB) ENDIF ENDDO ! Compute octahedral latitudes DO JL = 1, JPNLAT / 2 NLOEN(JL) = 20 + 4 * (JL - 1) NLOEN(JPNLAT - JL + 1) = NLOEN(JL) END DO ! Initialise ecTrans CALL SETUP_TRANS0(KOUT=IOUT, KERR=IERR, KPRGPNS=IPRGPNS, KPRGPEW=IPRGPEW, KPRTRW=IPRTRW, & & LDMPOFF=.NOT. LLUSE_MPI) CALL SETUP_TRANS(KSMAX=JPTRUNCATION, KDGL=2 * (JPTRUNCATION + 1), KLOEN=NLOEN) CALL TRANS_INQ(KGPTOTG=IGPTOTG, KGPTOT=IGPTOT) ! Initialise grid point arrays IGPBLKS = (IGPTOT - 1) / JPPROMA + 1 ALLOCATE(ZX1(JPPROMA,JPNUM_FIELDS,IGPBLKS)) ALLOCATE(ZX2(JPPROMA,JPNUM_FIELDS,IGPBLKS)) ALLOCATE(ZPRODUCT(JPPROMA,JPNUM_FIELDS,IGPBLKS)) ! Initialise X1 and Y2 with random numbers DO JP = 1, JPPROMA DO JF = 1, JPNUM_FIELDS DO JBLK = 1, IGPBLKS CALL RANDOM_NUMBER(ZRAND) ZX1(JP,JF,JBLK) = (1.0_JPRB - 2.0_JPRB * ZRAND) ENDDO ENDDO ENDDO DO JF = 1, JPNUM_FIELDS CALL RANDOM_NUMBER(ZRAND) ZY2(JF) = (1.0_JPRB - 2.0_JPRB * ZRAND) ENDDO ! Calculate TL(X1) CALL GPNORM_TRANSTL(ZX1, JPNUM_FIELDS, JPPROMA, ZY1) ! Calculate left hand side ZLHS = DOT_PRODUCT(ZY1, ZY2) ! Calculate AD(Y2) CALL GPNORM_TRANSAD(ZX2, JPNUM_FIELDS, JPPROMA, ZY2) ! Calculate right hand side ZPRODUCT = ZX1 * ZX2 ! Form the elementwise product in order to calculate the L2 norm of X1 .* X2 F%RW(:) = G%NLOEN(:) ! If we do this, the averaging operation in GPNORM_TRANS becomes an L2 norm CALL GPNORM_TRANS(ZPRODUCT, JPNUM_FIELDS, JPPROMA, ZPRODUCT_AVE, ZMIN_DUMMY, ZMAX_DUMMY, & & LDAVE_ONLY=.TRUE.) ZRHS = SUM(ZPRODUCT_AVE) ! Finish the L2 norm over all fields IF (IMYPROC == 1) THEN ! Calculate relative error between LHS and RHS ZRELATIVE_ERROR = ABS(ZLHS - ZRHS)/ABS(ZLHS) WRITE(IOUT, '(A,1E30.15)') ' = ', ZLHS WRITE(IOUT, '(A,1E30.15)') ' = ', ZRHS WRITE(IOUT, '(A,1E20.15)') 'Relative error = ', ZRELATIVE_ERROR ! Abort if relative error is > 5000 * machine epsilon ! All tested compilers seem to be happy with a threshold of 5000, though it is a bit arbitrary IF (ZRELATIVE_ERROR > 5000.0*EPSILON(1.0_JPRB)) THEN WRITE(IERR, '(A)') '*******************************' WRITE(IERR, '(A)') 'TEST_GPNORM_TRANS_ADJOINT: test failed' WRITE(IERR, '(A)') 'Relative error greater than 5000 * machine epsilon' WRITE(IERR, '(1E9.2,A3,1E9.2)') ZRELATIVE_ERROR, ' > ', 5000.0*EPSILON(1.0_JPRB) WRITE(IERR, '(A)') '*******************************' FLUSH(IERR) CALL TRANS_END CALL ABORT_TRANS("TEST_GPNORM_TRANS_ADJOINT: test failed") ENDIF ENDIF CALL TRANS_END IF (LLUSE_MPI) THEN CALL MPL_BARRIER() CALL MPL_END ENDIF END PROGRAM TEST_GPNORM_TRANS_ADJOINT ectrans-1.8.0/tests/trans/adjoint/test_adjoint.F900000664000175000017500000001520415174631767022256 0ustar alastairalastair! (C) Copyright 2005- ECMWF. ! ! 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. ! ! ================================================================================================== ! Adjoint test ! ================================================================================================== ! ! This program performs a rudimentary check of tangent-linear/adjoint correspondence of the inverse ! and direct spectral transform. ! ! The program checks the correspondence of and ! , which with infinite precision should match exactly. In practice ! there is some divergence due to rounding errors. In this program we check whether the two ! expressions are the same to within a tolerance of 2000 * machine epsilon. ! ! The check is only performed for scalar fields (PSPSCALAR). Wind fields are not checked. ! ! ================================================================================================== PROGRAM TEST_ADJOINT USE PARKIND1, ONLY: JPIM, JPRB USE MPL_MODULE, ONLY: MPL_INIT, MPL_MYRANK, MPL_NPROC, MPL_BARRIER, MPL_END USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE UTILS, ONLY: DETECT_MPIRUN, SCALPRODSP IMPLICIT NONE INTEGER(KIND=JPIM) :: NSMAX, NDGL, NPROC, NPRGPNS, NPRGPEW, NPRTRW, NPRTRV INTEGER(KIND=JPIM) :: NOUT, NERR, MYPROC, NSPECG, NSPEC2G INTEGER(KIND=JPIM) :: NFLEV, NFLEVG INTEGER(KIND=JPIM) :: NSPEC2, NGPTOT, NPROMA, NGPBLKS, MYSETV INTEGER(KIND=JPIM), ALLOCATABLE :: IVSET(:) INTEGER(KIND=JPIM), ALLOCATABLE :: NLOEN(:) INTEGER(KIND=JPIM) :: JLEV REAL(KIND=JPRB) , ALLOCATABLE :: ZSPECX(:,:), ZSPECY(:,:), ZSPECP(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZGX(:,:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZSPECYG(:,:), ZSPECXG(:,:) REAL(KIND=JPRB) , ALLOCATABLE :: ZRANDSP(:) REAL(KIND=JPRB) :: ZSC1, ZSC2, ZRELATIVE_ERROR INTEGER(KIND=JPIM) :: JA, JB, I LOGICAL :: LUSE_MPI INTEGER(KIND=JPIM) :: N INTEGER(KIND=JPIM), ALLOCATABLE :: SEED(:) #include "setup_trans0.h" #include "setup_trans.h" #include "trans_inq.h" #include "dir_trans.h" #include "inv_trans.h" #include "dir_transad.h" #include "inv_transad.h" #include "dist_grid.h" #include "dist_spec.h" #include "trans_end.h" ! Fix random number seed CALL RANDOM_SEED(SIZE=N) ALLOCATE(SEED(N)) SEED(:) = 1 CALL RANDOM_SEED(PUT=SEED) LUSE_MPI = DETECT_MPIRUN() NDGL = 32 ! Number of latitudes from pole to equator NFLEVG = 9 ! Number of levels NPROMA = 8 ! Gridpoint block size ! Determine spectral space parameters NSMAX = (2 * NDGL - 1) / 3 ! Full Gaussian grid NSPECG = (NSMAX+1)*(NSMAX+2)/2 NSPEC2G = NSPECG*2 IF (LUSE_MPI) THEN CALL MPL_INIT MYPROC = MPL_MYRANK() NPROC = MPL_NPROC() ELSE MYPROC = 1 NPROC = 1 ENDIF ! STDOUT and STDERR NOUT = 6 NERR = 0 ! Only output to stdout on first task IF (NPROC > 1) THEN IF (MYPROC /= 1) THEN OPEN(UNIT=NOUT, FILE='/dev/null') ENDIF ENDIF ! Compute E-W and V-W set sizes DO JA = INT(SQRT(REAL(NPROC,JPRB))), NPROC JB = NPROC / JA IF (JA * JB == NPROC) THEN NPRGPNS = MAX(JA, JB) NPRGPEW = MIN(JA, JB) NPRTRW = MAX(JA, JB) NPRTRV = MIN(JA, JB) ENDIF ENDDO MYSETV = MOD(MYPROC-1,NPRTRV)+1 ! Allocate global spectral arrays ALLOCATE(ZSPECYG(NFLEVG,NSPEC2G)) ALLOCATE(ZSPECXG(NFLEVG,NSPEC2G)) ! Array for storing random perturbations ALLOCATE(ZRANDSP(NSPEC2G)) ! Use a full Gaussian grid ALLOCATE(NLOEN(NDGL)) NLOEN(:) = 2*NDGL ! Initialise ecTrans CALL SETUP_TRANS0(KOUT=NOUT, KERR=NERR, KPRINTLEV=0, KMAX_RESOL=1, KPRGPNS=NPRGPNS, & & KPRGPEW=NPRGPEW, KPRTRW=NPRTRW, LDMPOFF=.NOT. LUSE_MPI) CALL SETUP_TRANS(KSMAX=NSMAX, KDGL=NDGL, KLOEN=NLOEN, LDSPLIT=.TRUE.) CALL TRANS_INQ(KSPEC2=NSPEC2, KGPTOT=NGPTOT) ! Calculate number of NPROMA blocks NGPBLKS = (NGPTOT - 1) / NPROMA + 1 ! Determine VSET allocation and number of local levels ALLOCATE(IVSET(NFLEVG)) NFLEV = 0 DO JLEV = 1, NFLEVG IVSET(JLEV) = MOD(JLEV,NPRTRV) + 1 IF (IVSET(JLEV) == MYSETV) THEN NFLEV = NFLEV + 1 ENDIF ENDDO ! Local spectral arrays ALLOCATE(ZSPECX(NFLEV,NSPEC2)) ALLOCATE(ZSPECY(NFLEV,NSPEC2)) ALLOCATE(ZSPECP(NFLEV,NSPEC2)) ! Temporary grid point array ALLOCATE(ZGX(NPROMA,NFLEVG,NGPBLKS)) ! Prepare perturbations (random numbers between -1 and +1) IF (MYPROC == 1) THEN DO JLEV=1,NFLEVG CALL RANDOM_NUMBER(ZRANDSP) ZSPECYG(JLEV,:) = (1.0_JPRB-2.0_JPRB*ZRANDSP(:)) CALL RANDOM_NUMBER(ZRANDSP) ZSPECXG(JLEV,:) = (1.0_JPRB-2.0_JPRB*ZRANDSP(:)) ENDDO ENDIF ! Distribute global spectral arrays CALL DIST_SPEC(PSPECG=ZSPECXG, KFDISTG=NFLEVG, KFROM=(/ (1, I = 1, NFLEVG) /), PSPEC=ZSPECX, & & KVSET=IVSET) CALL DIST_SPEC(PSPECG=ZSPECYG, KFDISTG=NFLEVG, KFROM=(/ (1, I = 1, NFLEVG) /), PSPEC=ZSPECY, & & KVSET=IVSET) ! Calculate DIR_TRANS(INV_TRANS(X)) CALL INV_TRANS(PSPSCALAR=ZSPECX, PGP=ZGX, KPROMA=NPROMA, KVSETSC=IVSET) CALL DIR_TRANS(PSPSCALAR=ZSPECP, PGP=ZGX, KPROMA=NPROMA, KVSETSC=IVSET) ! Calculate ZSC1 = SCALPRODSP(ZSPECP, ZSPECY, IVSET, NFLEV, NFLEVG, NSPEC2, NSPEC2G, NSMAX, MYPROC) ZSPECP = 0.0_JPRB ! Calculate INV_TRANSAD(DIR_TRANSAD(Y)) CALL DIR_TRANSAD(PSPSCALAR=ZSPECY, PGP=ZGX, KPROMA=NPROMA, KVSETSC=IVSET) CALL INV_TRANSAD(PSPSCALAR=ZSPECP, PGP=ZGX, KPROMA=NPROMA, KVSETSC=IVSET) ! Calculate ZSC2 = SCALPRODSP(ZSPECX, ZSPECP, IVSET, NFLEV, NFLEVG, NSPEC2, NSPEC2G, NSMAX, MYPROC) ! If I'm the first task, do the error check IF (MYPROC == 1) THEN ! Calculate relative error between and ZRELATIVE_ERROR = ABS(ZSC1 - ZSC2)/ABS(ZSC1) WRITE(NOUT, '(A,1E9.2)') ' = ', ZSC1 WRITE(NOUT, '(A,1E9.2)') ' = ', ZSC2 WRITE(NOUT, '(A,1E9.2)') 'Relative error = ', ZRELATIVE_ERROR ! Abort if relative error is > 2000 * machine epsilon ! All tested compilers seem to be happy with a threshold of 2000, though it is a bit arbitrary IF (ZRELATIVE_ERROR > 2000.0*EPSILON(1.0_JPRB)) THEN WRITE(NERR, '(A)') '*******************************' WRITE(NERR, '(A)') 'Adjoint test failed' WRITE(NERR, '(A)') 'Relative error greater than 2000 * machine epsilon' WRITE(NERR, '(1E9.2,A3,1E9.2)') ZRELATIVE_ERROR, ' > ', 2000.0*EPSILON(1.0_JPRB) WRITE(NERR, '(A)') '*******************************' FLUSH(NERR) CALL TRANS_END CALL ABORT_TRANS("Adjoint test failed") ENDIF ENDIF CALL TRANS_END IF (LUSE_MPI) THEN CALL MPL_BARRIER() CALL MPL_END ENDIF END PROGRAM TEST_ADJOINT ectrans-1.8.0/tests/trans/adjoint/utils.F900000664000175000017500000001074415174631767020733 0ustar alastairalastair! (C) Copyright 2026- ECMWF. ! ! 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. MODULE UTILS USE PARKIND1, ONLY: JPRB, JPIM IMPLICIT NONE PRIVATE PUBLIC :: DETECT_MPIRUN, SCALPRODSP, SCALPRODGP CONTAINS FUNCTION DETECT_MPIRUN() RESULT(LMPI_REQUIRED) USE EC_ENV_MOD, ONLY : EC_PUTENV LOGICAL :: LMPI_REQUIRED INTEGER :: ILEN INTEGER, PARAMETER :: NVARS = 4 CHARACTER(LEN=32), DIMENSION(NVARS) :: CMPIRUN_DETECT CHARACTER(LEN=4) :: CLENV INTEGER :: IVAR ! Environment variables that are set when mpirun, srun, aprun, ... are used CMPIRUN_DETECT(1) = 'OMPI_COMM_WORLD_SIZE' ! OPENMPI CMPIRUN_DETECT(2) = 'ALPS_APP_PE' ! CRAY PE CMPIRUN_DETECT(3) = 'PMI_SIZE' ! INTEL CMPIRUN_DETECT(4) = 'SLURM_NTASKS' ! SLURM LMPI_REQUIRED = .FALSE. DO IVAR = 1, NVARS CALL GET_ENVIRONMENT_VARIABLE(NAME=TRIM(CMPIRUN_DETECT(IVAR)), LENGTH=ILEN) IF (ILEN > 0) THEN LMPI_REQUIRED = .TRUE. EXIT ! Break ENDIF ENDDO CALL GET_ENVIRONMENT_VARIABLE(NAME="ECTRANS_USE_MPI", VALUE=CLENV, LENGTH=ILEN ) IF (ILEN > 0) THEN LMPI_REQUIRED = .TRUE. IF( TRIM(CLENV) == "0" .OR. TRIM(CLENV) == "OFF" .OR. TRIM(CLENV) == "off" .OR. TRIM(CLENV) == "F" ) THEN LMPI_REQUIRED = .FALSE. ENDIF CALL EC_PUTENV("DR_HOOK_ASSERT_MPI_INITIALIZED=0", OVERWRITE=.TRUE.) ENDIF END FUNCTION DETECT_MPIRUN FUNCTION SCALPRODSP(PSP1, PSP2, KVSET, KLEVL, KLEVG, KSPEC2, KSPEC2G, KSMAX, KMYPROC) RESULT(PSC) ! Scalar product in spectral space REAL(KIND=JPRB), INTENT(IN) :: PSP1(:,:) REAL(KIND=JPRB), INTENT(IN) :: PSP2(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM), INTENT(IN) :: KLEVL INTEGER(KIND=JPIM), INTENT(IN) :: KLEVG INTEGER(KIND=JPIM), INTENT(IN) :: KSPEC2 INTEGER(KIND=JPIM), INTENT(IN) :: KSPEC2G INTEGER(KIND=JPIM), INTENT(IN) :: KSMAX INTEGER(KIND=JPIM), INTENT(IN) :: KMYPROC REAL(KIND=JPRB) :: PSC INTEGER(KIND=JPIM), ALLOCATABLE :: MYMS(:), NASM0(:) INTEGER(KIND=JPIM) :: JMLOC, IM, JIR, JN, INM, JLEV, NUMP, I REAL(KIND=JPRB) :: ZMFACT, ZSP(KLEVL,KSPEC2), ZSPG(KLEVG,KSPEC2G) #include "trans_inq.h" #include "gath_spec.h" ! Get Ms I'm responsible for (MYMS) CALL TRANS_INQ(KNUMP=NUMP) ALLOCATE(MYMS(NUMP)) ALLOCATE(NASM0(0:KSMAX)) CALL TRANS_INQ(KMYMS=MYMS, KASM0=NASM0) PSC = 0.0_JPRB ZSP(:,:) = 0.0_JPRB !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JLEV,JMLOC,IM,ZMFACT,JIR,JN,INM) DO JLEV = 1, KLEVL DO JMLOC = 1, NUMP IM = MYMS(JMLOC) ZMFACT = 1.0_JPRB + REAL(MIN(1, IM), JPRB) DO JIR = 0, MIN(1, IM) DO JN = IM, KSMAX INM = NASM0(IM) + (JN - IM) * 2 + JIR ZSP(JLEV,INM) = PSP1(JLEV,INM) * PSP2(JLEV,INM) * ZMFACT ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GATH_SPEC(PSPECG=ZSPG, KFGATHG=KLEVG, KTO=(/ (1, I = 1, KLEVG) /), PSPEC=ZSP, KVSET=KVSET) IF (KMYPROC == 1) THEN PSC = SUM(ZSPG) ELSE PSC = 0.0_JPRB ENDIF END FUNCTION SCALPRODSP FUNCTION SCALPRODGP(RGP1, RGP2, KPROMA, KFIELD, KGPBLKS, KGPTOT, KGPTOTG, KMYPROC) RESULT(RSC) ! Scalar product in spectral space INTEGER(KIND=JPIM), INTENT(IN) :: KPROMA INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD INTEGER(KIND=JPIM), INTENT(IN) :: KGPBLKS REAL(KIND=JPRB), INTENT(IN) :: RGP1(KPROMA,KFIELD,KGPBLKS) REAL(KIND=JPRB), INTENT(IN) :: RGP2(KPROMA,KFIELD,KGPBLKS) INTEGER(KIND=JPIM), INTENT(IN) :: KGPTOT INTEGER(KIND=JPIM), INTENT(IN) :: KGPTOTG INTEGER(KIND=JPIM), INTENT(IN) :: KMYPROC REAL(KIND=JPRB) :: RSC INTEGER(KIND=JPIM) :: JLEV, JKGLO, IEND, IBL, JROF, I REAL(KIND=JPRB) :: RGP(KPROMA,KFIELD,KGPBLKS), RGPG(KGPTOTG,KFIELD) #include "gath_grid.h" RSC = 0.0_JPRB !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JLEV,JKGLO,IEND,IBL,JROF) DO JLEV = 1, KFIELD DO JKGLO = 1, KGPTOT, KPROMA IEND = MIN(KPROMA, KGPTOT - JKGLO + 1) IBL = (JKGLO - 1) / KPROMA+1 DO JROF = 1, IEND RGP(JROF,JLEV,IBL) = RGP1(JROF,JLEV,IBL) * RGP2(JROF,JLEV,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GATH_GRID(RGPG, KPROMA, KFIELD, KTO=[ (1, I = 1, KFIELD) ], PGP=RGP) IF (KMYPROC == 1) THEN RSC = SUM(RGPG) ELSE RSC = 0.0_JPRB ENDIF END FUNCTION SCALPRODGP END MODULE UTILS ectrans-1.8.0/tests/trans/adjoint/CMakeLists.txt0000664000175000017500000000535415174631767022054 0ustar alastairalastair# (C) Copyright 2026- ECMWF. # # 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. # Tests for adjoint functionality foreach( precision ${precisions} ) ecbuild_add_library( TARGET adjoint_utils_${precision} LINKER_LANGUAGE Fortran SOURCES utils.F90 PUBLIC_LIBS fiat trans_${precision} ) ecbuild_target_fortran_module_directory( TARGET adjoint_utils_${precision} MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/tests/trans/adjoint/module/adjoint_utils_${precision} ) foreach( platform ${platforms} ) if( "${platform}" MATCHES "cpu" ) set( platform_tag "" ) endif() if( "${platform}" MATCHES "gpu" ) set( platform_tag "_gpu" ) endif() foreach( mpi ${ntasks} ) # Add a test for tangent-linear/adjoint correspondence of INV_TRANS and DIR_TRANS combined ecbuild_add_test(TARGET ectrans_test_adjoint_${platform}_mpi${mpi}_${precision} SOURCES test_adjoint.F90 LIBS trans${platform_tag}_${precision} parkind_${precision} adjoint_utils_${precision} LINKER_LANGUAGE Fortran MPI ${mpi} OMP 1 ) # Add test for tangent-linear/adjoint correspondence of DIR_TRANS only ecbuild_add_test(TARGET ectrans_test_dirtrans_adjoint_${platform}_mpi${mpi}_${precision} SOURCES test_dirtrans_adjoint.F90 LIBS trans${platform_tag}_${precision} parkind_${precision} adjoint_utils_${precision} LINKER_LANGUAGE Fortran MPI ${mpi} OMP 1 ) # Add test for tangent-linear/adjoint correspondence of INV_TRANS only ecbuild_add_test(TARGET ectrans_test_invtrans_adjoint_${platform}_mpi${mpi}_${precision} SOURCES test_invtrans_adjoint.F90 LIBS trans${platform_tag}_${precision} parkind_${precision} adjoint_utils_${precision} LINKER_LANGUAGE Fortran MPI ${mpi} OMP 1 ) # GPNORMTRANS_TL/AD are not yet implemented for GPU if( NOT "${platform}" MATCHES "gpu" ) # Add a test for tangent-linear/adjoint correspondence of GPNORM_TRANSTL/AD ecbuild_add_test(TARGET ectrans_test_gpnorm_trans_adjoint_${platform}_mpi${mpi}_${precision} SOURCES test_gpnorm_adjoint.F90 LIBS trans${platform_tag}_${precision} parkind_${precision} adjoint_utils_${precision} LINKER_LANGUAGE Fortran MPI ${mpi} OMP 1 ) endif() endforeach() # mpi endforeach() # platform endforeach() # precision ectrans-1.8.0/tests/trans/api/0000775000175000017500000000000015174631767016426 5ustar alastairalastairectrans-1.8.0/tests/trans/api/setup_trans/0000775000175000017500000000000015174631767020775 5ustar alastairalastairectrans-1.8.0/tests/trans/api/setup_trans/setup_trans_test_suite.F900000664000175000017500000002042715174631767026101 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! 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. MODULE SETUP_TRANS_TEST_SUITE USE PARKIND1, ONLY: JPIM, JPRD IMPLICIT NONE #include "setup_trans0.h" #include "setup_trans.h" #include "trans_end.h" ! Spectral truncation used for all tests below INTEGER(KIND=JPIM), PARAMETER :: TRUNCATION = 79 ! Number of latitudes used for all tests below INTEGER(KIND=JPIM), PARAMETER :: NDGL = 2 * (TRUNCATION + 1) LOGICAL :: LUSE_MPI INTEGER(KIND=JPIM) :: NPROC CONTAINS !--------------------------------------------------------------------------------------------------- ! Setup fixture SUBROUTINE SETUP_TEST(LCALL_SETUP_TRANS0) USE UTIL, ONLY: DETECT_MPIRUN USE MPL_MODULE, ONLY: MPL_INIT, MPL_NPROC LOGICAL, INTENT(IN), OPTIONAL :: LCALL_SETUP_TRANS0 LOGICAL :: LLCALL_SETUP_TRANS0 = .TRUE. ! Set up MPI LUSE_MPI = DETECT_MPIRUN() IF (LUSE_MPI) THEN CALL MPL_INIT NPROC = MPL_NPROC() ELSE NPROC = 1 ENDIF IF (PRESENT(LCALL_SETUP_TRANS0)) THEN LLCALL_SETUP_TRANS0 = LCALL_SETUP_TRANS0 END IF IF (LLCALL_SETUP_TRANS0) CALL SETUP_TRANS0(LDMPOFF=.NOT. LUSE_MPI, KPRGPNS=NPROC) END SUBROUTINE SETUP_TEST !--------------------------------------------------------------------------------------------------- ! Teardown fixture SUBROUTINE END_TEST USE MPL_MODULE, ONLY: MPL_END CALL TRANS_END IF (LUSE_MPI) THEN CALL MPL_END(LDMEMINFO=.FALSE.) ENDIF END SUBROUTINE END_TEST !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS without first calling SETUP_TRANS0 - should fail INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_WITHOUT_SETUP_TRANS0() RESULT(RET) BIND(C) CALL SETUP_TEST(LCALL_SETUP_TRANS0=.FALSE.) CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL) RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_WITHOUT_SETUP_TRANS0 !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with regular lat-lon grid of 2*(TRUNCATION+1) latitudes INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_BASIC() RESULT(RET) BIND(C) CALL SETUP_TEST CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_BASIC !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with two resolutions (regular grid) INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_MULTIPLE_RESOLUTIONS() RESULT(RET) BIND(C) INTEGER(KIND=JPIM), PARAMETER :: TRUNCATION_1 = 39, TRUNCATION_2 = 79 CALL SETUP_TEST(LCALL_SETUP_TRANS0=.FALSE.) CALL SETUP_TRANS0(LDMPOFF=.NOT. LUSE_MPI, KPRGPNS=NPROC, KMAX_RESOL=2) CALL SETUP_TRANS(KSMAX=TRUNCATION_1, KDGL=2 * (TRUNCATION_1 + 1)) CALL SETUP_TRANS(KSMAX=TRUNCATION_2, KDGL=2 * (TRUNCATION_2 + 1)) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_MULTIPLE_RESOLUTIONS !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with an odd number of latitudes - should fail INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_ODD_NDGL() RESULT(RET) BIND(C) CALL SETUP_TEST CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL - 1) RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_ODD_NDGL !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with octahedral grid of 2*(TRUNCATION+1) latitudes INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_OCTAHEDRAL() RESULT(RET) BIND(C) INTEGER(KIND=JPIM) :: ILOEN(NDGL) INTEGER(KIND=JPIM) :: I CALL SETUP_TEST ! Define octahedral grid DO I = 1, TRUNCATION + 1 ILOEN(I) = 20 + 4 * I ILOEN(NDGL - I + 1) = ILOEN(I) END DO CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, KLOEN=ILOEN) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_OCTAHEDRAL !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with LDSPLIT option enabled INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_LDSPLIT() RESULT(RET) BIND(C) CALL SETUP_TEST CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, LDSPLIT=.TRUE.) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_LDSPLIT !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with stretch factor passed INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_STRETCHING() RESULT(RET) BIND(C) INTEGER(KIND=JPIM) :: ILOEN(NDGL) INTEGER(KIND=JPIM) :: I CALL SETUP_TEST ! Define octahedral grid DO I = 1, TRUNCATION + 1 ILOEN(I) = 20 + 4 * I ILOEN(NDGL - I + 1) = ILOEN(I) END DO CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, KLOEN=ILOEN, PSTRET=2.0_JPRD) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_STRETCHING !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with fast Legendre transform INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_FLT() RESULT(RET) BIND(C) INTEGER(KIND=JPIM) :: ILOEN(NDGL) INTEGER(KIND=JPIM) :: I CALL SETUP_TEST ! Define octahedral grid DO I = 1, TRUNCATION + 1 ILOEN(I) = 20 + 4 * I ILOEN(NDGL - I + 1) = ILOEN(I) END DO CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, KLOEN=ILOEN, LDUSEFLT=.TRUE.) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_FLT !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with all fields passed to FFTW at ocne INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_ALL_FFTW() RESULT(RET) BIND(C) INTEGER(KIND=JPIM) :: ILOEN(NDGL) INTEGER(KIND=JPIM) :: I CALL SETUP_TEST ! Define octahedral grid DO I = 1, TRUNCATION + 1 ILOEN(I) = 20 + 4 * I ILOEN(NDGL - I + 1) = ILOEN(I) END DO CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, KLOEN=ILOEN, LD_ALL_FFTW=.TRUE.) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_ALL_FFTW !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with Belusov algorithm INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_BELUSOV() RESULT(RET) BIND(C) INTEGER(KIND=JPIM) :: ILOEN(NDGL) INTEGER(KIND=JPIM) :: I CALL SETUP_TEST ! Define octahedral grid DO I = 1, TRUNCATION + 1 ILOEN(I) = 20 + 4 * I ILOEN(NDGL - I + 1) = ILOEN(I) END DO CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, KLOEN=ILOEN, LDUSERPNM=.TRUE.) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_BELUSOV !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with LGRIDONLY option enabled INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_GRIDONLY() RESULT(RET) BIND(C) CALL SETUP_TEST CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, LDGRIDONLY=.TRUE.) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_GRIDONLY !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with LDSPSETUPONLY option enabled INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_SPSETUPONLY() RESULT(RET) BIND(C) CALL SETUP_TEST CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, LDSPSETUPONLY=.TRUE.) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_SPSETUPONLY !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS with LDPNMONLY option enabled INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_PNMONLY() RESULT(RET) BIND(C) CALL SETUP_TEST CALL SETUP_TRANS(KSMAX=TRUNCATION, KDGL=NDGL, LDPNMONLY=.TRUE.) CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS_PNMONLY !--------------------------------------------------------------------------------------------------- END MODULE SETUP_TRANS_TEST_SUITE ectrans-1.8.0/tests/trans/api/setup_trans/CMakeLists.txt0000664000175000017500000000315015174631767023534 0ustar alastairalastair# (C) Copyright 2025- ECMWF. # # 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. # API tests for SETUP_TRANS # Define list of SETUP_TRANS tests set( test_list ectrans_test_trans_api_setup_trans_without_setup_trans0 ectrans_test_trans_api_setup_trans_basic ectrans_test_trans_api_setup_trans_multiple_resolutions ectrans_test_trans_api_setup_trans_odd_ndgl ectrans_test_trans_api_setup_trans_octahedral ectrans_test_trans_api_setup_trans_ldsplit ectrans_test_trans_api_setup_trans_stretching ectrans_test_trans_api_setup_trans_flt ectrans_test_trans_api_setup_trans_all_fftw ectrans_test_trans_api_setup_trans_belusov ectrans_test_trans_api_setup_trans_gridonly ectrans_test_trans_api_setup_trans_spsetuponly ectrans_test_trans_api_setup_trans_pnmonly ) # Declare tests that WILL_FAIL set( will_fail_list ectrans_test_trans_api_setup_trans_odd_ndgl ectrans_test_trans_api_setup_trans_without_setup_trans0 ) # Note: the FLT is not implemented for the GPU backend generate_api_test_suite( SUITE_NAME setup_trans_test_suite TESTS ${test_list} WILL_FAIL_LIST ${will_fail_list} MPIxOMPS "0x1" "0x8" "1x1" "1x8" "2x1" "2x8" BACKENDS "cpu_sp" "cpu_dp" "gpu_sp" "gpu_dp" EXCLUDES "flt.*gpu" ) ectrans-1.8.0/tests/trans/api/fpe_trapping.cc0000664000175000017500000001617615174631767021426 0ustar alastairalastair/* (C) Copyright 2026- ECMWF. 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. */ // This file takes care of enabling floating point exception trapping for the API tests, // and defines a signal handler to print a stack trace when an FPE is encountered. // It was taken and adapted from the github.com/ecmwf/atlas repository, // where it has been used for a while to enable FPE trapping for the Atlas tests. // // Note that on Apple Silicon a SIGFPE may be posing as a SIGILL, so we also check for that case in the signal handler. // // This could eventually be moved to a more central location, or be incorporated with DR_HOOK // if we want to enable FPE trapping for more than just the API tests, but for now this is sufficient. #include #include #include #include #include #include #include extern "C" void linux_trbk(void); #ifndef HAVE_FEENABLEEXCEPT #error "This code requires HAVE_FEENABLEEXCEPT to compile" #endif #ifndef HAVE_FEDISABLEEXCEPT #error "This code requires HAVE_FEDISABLEEXCEPT to compile" #endif #if HAVE_FEENABLEEXCEPT static int ectrans_test_feenableexcept(unsigned int excepts) { return ::feenableexcept(excepts); } static int ectrans_test_fedisableexcept(unsigned int excepts) { return ::fedisableexcept(excepts); } #elif defined(__APPLE__) static int ectrans_test_feenableexcept(unsigned int excepts) { static fenv_t fenv; unsigned int new_excepts = excepts & FE_ALL_EXCEPT; unsigned int old_excepts; // previous masks if (::fegetenv(&fenv)) { return -1; } #if defined(__arm64__) old_excepts = fenv.__fpsr & FE_ALL_EXCEPT; fenv.__fpsr |= new_excepts; fenv.__fpcr |= (new_excepts << 8); #else old_excepts = fenv.__control & FE_ALL_EXCEPT; fenv.__control &= ~new_excepts; fenv.__mxcsr &= ~(new_excepts << 7); #endif return ::fesetenv(&fenv) ? -1 : old_excepts; } static int ectrans_test_fedisableexcept(unsigned int excepts) { static fenv_t fenv; unsigned int new_excepts = excepts & FE_ALL_EXCEPT; unsigned int old_excepts; // all previous masks if (::fegetenv(&fenv)) { return -1; } #if defined(__arm64__) old_excepts = fenv.__fpsr & FE_ALL_EXCEPT; fenv.__fpsr &= ~new_excepts; fenv.__fpcr &= ~(new_excepts << 8); #else old_excepts = fenv.__control & FE_ALL_EXCEPT; fenv.__control |= new_excepts; fenv.__mxcsr |= (new_excepts << 7); #endif return ::fesetenv(&fenv) ? -1 : old_excepts; } #else static int ectrans_test_feenableexcept(unsigned int excepts) { return 0; } static int ectrans_test_fedisableexcept(unsigned int excepts) { return 0; } #endif [[noreturn]] void ectrans_test_signal_handler(int signum, siginfo_t* si, [[maybe_unused]] void* ucontext) { std::string signal_code; if (signum == SIGFPE) { switch (si->si_code) { case FPE_FLTDIV: signal_code = " [FE_DIVBYZERO]"; break; case FPE_FLTINV: signal_code = " [FE_INVALID]"; break; case FPE_FLTOVF: signal_code = " [FE_OVERFLOW]"; break; case FPE_FLTUND: signal_code = " [FE_UNDERFLOW]"; break; case FPE_FLTRES: signal_code = " [FE_INEXACT]"; break; } } #if defined(__APPLE__) && defined(__arm64__) if (signum == SIGILL) { // On Apple Silicon a SIGFPE may be posing as a SIGILL // See: // https://developer.apple.com/forums/thread/689159?answerId=733736022 // https://developer.arm.com/documentation/ddi0595/2020-12/AArch64-Registers/ESR-EL1--Exception-Syndrome-Register--EL1-?lang=en#fieldset_0-24_0_16-1_1 auto esr = reinterpret_cast(ucontext)->uc_mcontext->__es.__esr; auto is_floating_point_exception = [&esr]() { constexpr unsigned long fpe_mask = 2952790016; // bits: 10110000000000000000000000000000 constexpr std::bitset<32> fpe_mask_bits(fpe_mask); return((fpe_mask_bits & std::bitset<32>(esr)) == fpe_mask_bits); }; auto test_esr = [&esr](auto pos) -> bool { return std::bitset<32>(esr).test(pos); }; if (is_floating_point_exception()) { // SIGILL is posing as a SIGFPE constexpr size_t IOF = 0; // invalid operation constexpr size_t DZF = 1; // divide-by-zero constexpr size_t OFF = 2; // overflow constexpr size_t UFF = 3; // underflow constexpr size_t IXF = 4; // inexact constexpr size_t IDF = 7; // denormal if (test_esr(IOF)) { signal_code = " [FE_INVALID]"; } else if(test_esr(DZF)) { signal_code = " [FE_DIVBYZERO]"; } else if(test_esr(OFF)) { signal_code = " [FE_OVERFLOW]"; } else if(test_esr(UFF)) { signal_code = " [FE_UNDERFLOW]"; } else if(test_esr(IXF)) { signal_code = " [FE_INEXACT]"; } else if(test_esr(IDF)) { signal_code = " [FE_DENORMAL]"; } } } #endif std::ostream& out = std::cerr; out << "\n" << "=========================================\n" << signal_code << " (signal intercepted by ectrans_test_signal_handler [ectrans/tests/trans/api/fpe_trapping.cc])\n" << "=========================================\n"; linux_trbk(); out << "=========================================\n" << std::endl; // Restore the default signal handler and re-raise the signal to allow for normal termination and core dump generation. std::signal(signum, SIG_DFL); std::raise(signum); // Just in case we end up here, which normally we shouldn't. std::cerr << "Exit\n" << std::endl; std::_Exit(EXIT_FAILURE); } extern "C" { void ectrans_test_enable_fpe() { char* ECTRANS_TEST_ENABLE_FPE = getenv("ECTRANS_TEST_ENABLE_FPE"); // Don't enable FPE trapping if the environment variable ECTRANS_TEST_ENABLE_FPE is set to "0", // to allow for easier debugging of tests when desired without having to modify the code. if (ECTRANS_TEST_ENABLE_FPE != nullptr && std::strcmp(ECTRANS_TEST_ENABLE_FPE, "0") == 0) { return; } struct sigaction sa; std::memset(&sa, 0, sizeof(sa)); sa.sa_sigaction = ectrans_test_signal_handler; sa.sa_flags = SA_SIGINFO; if (sigaction(SIGFPE, &sa, nullptr) == -1) { std::cerr << "Failed to set signal handler for SIGFPE: " << std::strerror(errno) << std::endl; } if (sigaction(SIGILL, &sa, nullptr) == -1) { std::cerr << "Failed to set signal handler for SIGILL: " << std::strerror(errno) << std::endl; } ectrans_test_feenableexcept(FE_DIVBYZERO | FE_INVALID | FE_OVERFLOW); } }ectrans-1.8.0/tests/trans/api/dir_trans/0000775000175000017500000000000015174631767020413 5ustar alastairalastairectrans-1.8.0/tests/trans/api/dir_trans/dir_trans_test_suite.F900000664000175000017500000003626115174631767025140 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! 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. MODULE DIR_TRANS_TEST_SUITE USE PARKIND1, ONLY: JPIM, JPRB, JPRD USE MPL_MODULE, ONLY: MPL_INIT, MPL_NPROC, MPL_MYRANK, MPL_ALLREDUCE, MPL_END IMPLICIT NONE #include "setup_trans0.h" #include "setup_trans.h" #include "trans_inq.h" #include "dist_grid.h" #include "dir_trans.h" #include "trans_end.h" ! Spectral truncation used for all tests below INTEGER(KIND=JPIM), PARAMETER :: JPTRUNCATION = 79 ! Number of latitudes used for all tests below INTEGER(KIND=JPIM), PARAMETER :: JPNGDL = 2 * (JPTRUNCATION + 1) ! Tolerance for "close to zero" REAL(KIND=JPRB), PARAMETER :: PPTOLERANCE = 100.0_JPRB * EPSILON(1.0_JPRB) ! JPPROMA blocking factor INTEGER(KIND=JPIM), PARAMETER :: JPPROMA = 16 ! Earth radius in metres REAL(KIND=JPRD), PARAMETER :: PPEARTH_RADIUS = 6371229.0_JPRD LOGICAL :: LUSE_MPI CONTAINS !--------------------------------------------------------------------------------------------------- ! Approximate equality check for reals ELEMENTAL LOGICAL FUNCTION APPROX_EQ(PA, PB, PTOL) RESULT(KRET) REAL(KIND=JPRB), INTENT(IN) :: PA REAL(KIND=JPRB), INTENT(IN) :: PB REAL(KIND=JPRB), INTENT(IN), OPTIONAL :: PTOL IF (PRESENT(PTOL)) THEN KRET = ABS(PA - PB) < PTOL ELSE KRET = ABS(PA - PB) < PPTOLERANCE END IF END FUNCTION APPROX_EQ ! Initialise global field with all ones and distribute it FUNCTION GET_INPUT_FIELD(KMY_PROC, KGPTOTG, KGPBLKS, KFIELDS) RESULT(PGP) INTEGER(KIND=JPIM), INTENT(IN) :: KMY_PROC INTEGER(KIND=JPIM), INTENT(IN) :: KGPTOTG INTEGER(KIND=JPIM), INTENT(IN) :: KGPBLKS INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS REAL(KIND=JPRB), ALLOCATABLE :: ZGPG(:,:), PGP(:,:,:) INTEGER(KIND=JPIM) :: I ! Initialise global field IF (KMY_PROC == 1) THEN ALLOCATE(ZGPG(KGPTOTG,KFIELDS)) ! Set all of the input to one ZGPG(:,:) = 1.0_JPRB ENDIF ! Initialise distributed fields ALLOCATE(PGP(JPPROMA,KFIELDS,KGPBLKS)) ! Distribute field from first task to other tasks IF (KMY_PROC == 1) THEN CALL DIST_GRID(PGPG=ZGPG, KFDISTG=KFIELDS, KFROM=[(1, I = 1, KFIELDS)], PGP=PGP, KPROMA=JPPROMA) ELSE CALL DIST_GRID(KFDISTG=KFIELDS, KFROM=[(1, I = 1, KFIELDS)], PGP=PGP, KPROMA=JPPROMA) ENDIF IF (KMY_PROC == 1) DEALLOCATE(ZGPG) END FUNCTION GET_INPUT_FIELD FUNCTION ROTATIONAL_WIND(KGPBLKS, K_REGIONS_NS, K_REGIONS_EW) RESULT(PGP) INTEGER(KIND=JPIM), INTENT(IN) :: KGPBLKS INTEGER(KIND=JPIM), INTENT(IN) :: K_REGIONS_NS INTEGER(KIND=JPIM), INTENT(IN) :: K_REGIONS_EW REAL(KIND=JPRB), ALLOCATABLE :: PGP(:,:,:) INTEGER(KIND=JPIM) :: IPTRFLOFF, IMY_REGION_NS, IMY_REGION_EW INTEGER(KIND=JPIM), DIMENSION(K_REGIONS_NS) :: IFRSTLAT, ILSTLAT REAL(KIND=JPRD) :: ZMU(JPNGDL) INTEGER(KIND=JPIM), DIMENSION(JPNGDL + K_REGIONS_NS - 1, K_REGIONS_EW) :: NSTA, NONL INTEGER(KIND=JPIM) :: ILAT, IFIRSTLAT, ILASTLAT, IBL, JROF, JGLAT, ISTLON, IENDLON, JLON REAL(KIND=JPRB) :: ZLAT CALL TRANS_INQ(KPTRFLOFF=IPTRFLOFF, KMY_REGION_NS=IMY_REGION_NS, KFRSTLAT=IFRSTLAT, & & KLSTLAT=ILSTLAT, PMU=ZMU, KMY_REGION_EW=IMY_REGION_EW, KSTA=NSTA, KONL=NONL) ILAT = IPTRFLOFF IFIRSTLAT = IFRSTLAT(IMY_REGION_NS) ILASTLAT = ILSTLAT(IMY_REGION_NS) ALLOCATE(PGP(JPPROMA, 2, KGPBLKS)) IBL = 1 JROF = 1 DO JGLAT = IFIRSTLAT, ILASTLAT ZLAT = ASIN(ZMU(JGLAT)) ILAT = ILAT + 1 ISTLON = NSTA(ILAT, IMY_REGION_EW) IENDLON = ISTLON - 1 + NONL(ILAT, IMY_REGION_EW) DO JLON = ISTLON, IENDLON PGP(JROF, 1, IBL) = COS(ZLAT) ! U = A * COS(THETA) PGP(JROF, 2, IBL) = 0.0_JPRB ! V = 0 JROF = JROF + 1 IF (JROF > JPPROMA) THEN JROF = 1 IBL = IBL + 1 ENDIF ENDDO ENDDO END FUNCTION ROTATIONAL_WIND ! Determine if this task handles the m=0 mode LOGICAL FUNCTION HAVE_M0_MODE() INTEGER :: NUM_MY_ZON_WNS INTEGER, ALLOCATABLE :: MY_ZON_WNS(:) CALL TRANS_INQ(KNUMP=NUM_MY_ZON_WNS) ALLOCATE(MY_ZON_WNS(NUM_MY_ZON_WNS)) CALL TRANS_INQ(KMYMS=MY_ZON_WNS) HAVE_M0_MODE = ANY(MY_ZON_WNS == 0) END FUNCTION HAVE_M0_MODE ! Setup fixture SUBROUTINE SETUP_TEST(KSPEC2, KGPTOTG, KGPTOT, KGPBLKS, KMY_PROC, K_REGIONS_NS, K_REGIONS_EW) USE UTIL, ONLY: DETECT_MPIRUN INTEGER(KIND=JPIM), INTENT(OUT) :: KSPEC2 INTEGER(KIND=JPIM), INTENT(OUT) :: KGPTOTG INTEGER(KIND=JPIM), INTENT(OUT) :: KGPTOT INTEGER(KIND=JPIM), INTENT(OUT) :: KGPBLKS INTEGER(KIND=JPIM), INTENT(OUT) :: KMY_PROC INTEGER(KIND=JPIM), INTENT(OUT) :: K_REGIONS_NS INTEGER(KIND=JPIM), INTENT(OUT) :: K_REGIONS_EW INTEGER(KIND=JPIM) :: ILOEN(JPNGDL) INTEGER(KIND=JPIM) :: I INTEGER(KIND=JPIM) :: IPROC ! Set up MPI LUSE_MPI = DETECT_MPIRUN() IF (LUSE_MPI) THEN CALL MPL_INIT IPROC = MPL_NPROC() KMY_PROC = MPL_MYRANK() ELSE IPROC = 1 KMY_PROC = 1 ENDIF CALL SETUP_TRANS0(LDMPOFF=.NOT. LUSE_MPI, KPRGPNS=IPROC, KPRGPEW=1, KPRTRW=IPROC, & & K_REGIONS_NS=K_REGIONS_NS, K_REGIONS_EW=K_REGIONS_EW, PRAD=PPEARTH_RADIUS) ! Define octahedral grid DO I = 1, JPTRUNCATION + 1 ILOEN(I) = 20 + 4 * I ILOEN(JPNGDL - I + 1) = ILOEN(I) END DO CALL SETUP_TRANS(KSMAX=JPTRUNCATION, KDGL=JPNGDL, KLOEN=ILOEN) CALL TRANS_INQ(KSPEC2=KSPEC2, KGPTOTG=KGPTOTG, KGPTOT=KGPTOT) ! Number of JPPROMA blocks KGPBLKS = (KGPTOT - 1) / JPPROMA + 1 END SUBROUTINE SETUP_TEST ! Tear down fixture SUBROUTINE CLEANUP_TEST CALL TRANS_END IF (LUSE_MPI) THEN CALL MPL_END(LDMEMINFO=.FALSE.) ENDIF END SUBROUTINE CLEANUP_TEST !--------------------------------------------------------------------------------------------------- ! NOTES: ! - For now there is only a very primitive correctness check. For scalar fields we set the input to ! one and check that only the (0,0) mode (global mean) is one and all the rest are zero. For wind ! fields we set the input to one and check that vorticity and divergence are both zero. !--------------------------------------------------------------------------------------------------- ! Test DIR_TRANS with call mode 1 and just one scalar field INTEGER FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_1_SCALAR_1() RESULT(KRET) BIND(C) REAL(KIND=JPRB), ALLOCATABLE :: ZGP(:,:,:), ZSPSCALAR(:,:) INTEGER(KIND=JPIM) :: ISPEC2, IGPTOTG, IGPTOT, IMY_PROC, IGPBLKS, I_REGIONS_NS, I_REGIONS_EW ! Set up everything CALL SETUP_TEST(ISPEC2, IGPTOTG, IGPTOT, IGPBLKS, IMY_PROC, I_REGIONS_NS, I_REGIONS_EW) ZGP = GET_INPUT_FIELD(IMY_PROC, IGPTOTG, IGPBLKS, 1) ALLOCATE(ZSPSCALAR(1,ISPEC2)) CALL DIR_TRANS(PGP=ZGP, PSPSCALAR=ZSPSCALAR, KPROMA=JPPROMA) ! Check only the (0,0) mode (global mean) is one and all the rest are zero IF (HAVE_M0_MODE()) THEN KRET = MERGE(0, 1, APPROX_EQ(ZSPSCALAR(1,1), 1.0_JPRB) .AND. & & ALL(APPROX_EQ(ZSPSCALAR(1,2:), 0.0_JPRB))) ELSE KRET = MERGE(0, 1, ALL(APPROX_EQ(ZSPSCALAR, 0.0_JPRB))) ENDIF IF (LUSE_MPI) CALL MPL_ALLREDUCE(KRET, CDOPER="MAX") ! Tear down everything DEALLOCATE(ZSPSCALAR, ZGP) CALL CLEANUP_TEST END FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_1_SCALAR_1 !--------------------------------------------------------------------------------------------------- ! Test DIR_TRANS with call mode 1 and 1-level wind fields INTEGER FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_1_WIND_1() RESULT(KRET) BIND(C) REAL(KIND=JPRB), ALLOCATABLE :: ZGP(:,:,:), ZSPVOR(:,:), ZSPDIV(:,:) INTEGER(KIND=JPIM) :: ISPEC2, IGPTOTG, IGPTOT, IMY_PROC, IGPBLKS, I_REGIONS_NS, I_REGIONS_EW REAL(KIND=JPRB) :: ZCORRECT_VORTICITY_VALUE ! Set up everything CALL SETUP_TEST(ISPEC2, IGPTOTG, IGPTOT, IGPBLKS, IMY_PROC, I_REGIONS_NS, I_REGIONS_EW) ZGP = ROTATIONAL_WIND(IGPBLKS, I_REGIONS_NS, I_REGIONS_EW) ALLOCATE(ZSPVOR(1,ISPEC2)) ALLOCATE(ZSPDIV(1,ISPEC2)) CALL DIR_TRANS(PGP=ZGP, PSPVOR=ZSPVOR, PSPDIV=ZSPDIV, KPROMA=JPPROMA) IF (HAVE_M0_MODE()) THEN ! epsilon_{m=0}^{n=1} = sqrt((n^2 - m^2)/(4n^2 - 1)) = sqrt(1/3) ZCORRECT_VORTICITY_VALUE = 2.0_JPRB * SQRT(1.0_JPRB / 3.0_JPRB) / PPEARTH_RADIUS ! Check all criteria KRET = 0 ! Check divergence is all zero IF (ANY(.NOT. APPROX_EQ(ZSPDIV, 0.0_JPRB))) KRET = 1 ! Check all irrelevant vorticity modes are zero IF (ANY(.NOT. APPROX_EQ(ZSPVOR(1,1:2), 0.0_JPRB))) KRET = 1 ! Check selected harmonic has the correct value IF (.NOT. APPROX_EQ(ZSPVOR(1,3), ZCORRECT_VORTICITY_VALUE)) KRET = 1 ELSE KRET = MERGE(0, 1, ALL(APPROX_EQ(ZSPVOR, 0.0_JPRB) .AND. ALL(APPROX_EQ(ZSPDIV, 0.0_JPRB)))) ENDIF IF (LUSE_MPI) CALL MPL_ALLREDUCE(KRET, CDOPER="MAX") ! Tear down everything DEALLOCATE(ZSPDIV, ZSPVOR, ZGP) CALL CLEANUP_TEST END FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_1_WIND_1 !--------------------------------------------------------------------------------------------------- ! Test DIR_TRANS with call mode 1 and 1-level wind fields and 1 scalar field INTEGER FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_1_WIND_1_SCALAR_1() RESULT(KRET) BIND(C) REAL(KIND=JPRB), ALLOCATABLE :: ZGP(:,:,:), ZSPVOR(:,:), ZSPDIV(:,:), ZSPSCALAR(:,:) INTEGER(KIND=JPIM) :: ISPEC2, IGPTOTG, IGPTOT, IMY_PROC, IGPBLKS, I_REGIONS_NS, I_REGIONS_EW REAL(KIND=JPRB) :: ZCORRECT_VORTICITY_VALUE ! Set up everything CALL SETUP_TEST(ISPEC2, IGPTOTG, IGPTOT, IGPBLKS, IMY_PROC, I_REGIONS_NS, I_REGIONS_EW) ALLOCATE(ZGP(JPPROMA, 3, IGPBLKS)) ALLOCATE(ZSPVOR(1,ISPEC2)) ALLOCATE(ZSPDIV(1,ISPEC2)) ALLOCATE(ZSPSCALAR(1,ISPEC2)) ZGP(:,1:2,:) = ROTATIONAL_WIND(IGPBLKS, I_REGIONS_NS, I_REGIONS_EW) ZGP(:,3:3,:) = GET_INPUT_FIELD(IMY_PROC, IGPTOTG, IGPBLKS, 1) CALL DIR_TRANS(PGP=ZGP, PSPVOR=ZSPVOR, PSPDIV=ZSPDIV, PSPSCALAR=ZSPSCALAR, KPROMA=JPPROMA) IF (HAVE_M0_MODE()) THEN ! epsilon_{m=0}^{n=1} = sqrt((n^2 - m^2)/(4n^2 - 1)) = sqrt(1/3) ZCORRECT_VORTICITY_VALUE = 2.0_JPRB * SQRT(1.0_JPRB / 3.0_JPRB) / PPEARTH_RADIUS ! Check all criteria KRET = 0 ! Check all non-(0,0) modes of the scalar field are zero IF (.NOT. ALL(APPROX_EQ(ZSPSCALAR(1,2:), 0.0_JPRB))) KRET = 1 ! Check the (0,0) mode is one IF (.NOT. APPROX_EQ(ZSPSCALAR(1,1), 1.0_JPRB)) KRET = 1 ! Check divergence is all zero IF (ANY(.NOT. APPROX_EQ(ZSPDIV, 0.0_JPRB))) KRET = 1 ! Check all irrelevant vorticity modes are zero IF (ANY(.NOT. APPROX_EQ(ZSPVOR(1,1:2), 0.0_JPRB))) KRET = 1 ! Check selected harmonic has the correct value IF (.NOT. APPROX_EQ(ZSPVOR(1,3), ZCORRECT_VORTICITY_VALUE)) KRET = 1 ELSE IF (ALL(APPROX_EQ(ZSPVOR, 0.0_JPRB)) .AND. ALL(APPROX_EQ(ZSPDIV, 0.0_JPRB)) .AND. & & ALL(APPROX_EQ(ZSPSCALAR, 0.0_JPRB))) THEN KRET = 0 ELSE KRET = 1 END IF ENDIF IF (LUSE_MPI) CALL MPL_ALLREDUCE(KRET, CDOPER="MAX") ! Tear down everything DEALLOCATE(ZSPSCALAR, ZSPDIV, ZSPVOR, ZGP) CALL CLEANUP_TEST END FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_1_WIND_1_SCALAR_1 !--------------------------------------------------------------------------------------------------- ! Test DIR_TRANS with call mode 2 and just one "3A" scalar field INTEGER FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_2_PGP3A_1() RESULT(KRET) BIND(C) REAL(KIND=JPRB), ALLOCATABLE :: ZGP3A(:,:,:,:), ZSPSC3A(:,:,:) INTEGER(KIND=JPIM) :: ISPEC2, IGPTOTG, IGPTOT, IMY_PROC, IGPBLKS, I_REGIONS_NS, I_REGIONS_EW ! Set up everything CALL SETUP_TEST(ISPEC2, IGPTOTG, IGPTOT, IGPBLKS, IMY_PROC, I_REGIONS_NS, I_REGIONS_EW) ALLOCATE(ZGP3A(JPPROMA,1,1,IGPBLKS)) ZGP3A(:,1,:,:) = GET_INPUT_FIELD(IMY_PROC, IGPTOTG, IGPBLKS, 1) ALLOCATE(ZSPSC3A(1,ISPEC2,1)) CALL DIR_TRANS(PGP3A=ZGP3A, PSPSC3A=ZSPSC3A, KPROMA=JPPROMA) ! Check only the (0,0) mode (global mean) is one and all the rest are zero IF (HAVE_M0_MODE()) THEN KRET = MERGE(0, 1, APPROX_EQ(ZSPSC3A(1,1,1), 1.0_JPRB) .AND. & & ALL(APPROX_EQ(ZSPSC3A(1,2:,1), 0.0_JPRB))) ELSE KRET = MERGE(0, 1, ALL(APPROX_EQ(ZSPSC3A, 0.0_JPRB))) ENDIF IF (LUSE_MPI) CALL MPL_ALLREDUCE(KRET, CDOPER="MAX") ! Tear down everything DEALLOCATE(ZSPSC3A, ZGP3A) CALL CLEANUP_TEST END FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_2_PGP3A_1 !--------------------------------------------------------------------------------------------------- ! Test DIR_TRANS with call mode 2 and just one "3B" scalar field INTEGER FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_2_PGP3B_1() RESULT(KRET) BIND(C) REAL(KIND=JPRB), ALLOCATABLE :: ZGP3B(:,:,:,:), ZSPSC3B(:,:,:) INTEGER(KIND=JPIM) :: ISPEC2, IGPTOTG, IGPTOT, IMY_PROC, IGPBLKS, I_REGIONS_NS, I_REGIONS_EW ! Set up everything CALL SETUP_TEST(ISPEC2, IGPTOTG, IGPTOT, IGPBLKS, IMY_PROC, I_REGIONS_NS, I_REGIONS_EW) ALLOCATE(ZGP3B(JPPROMA,1,1,IGPBLKS)) ZGP3B(:,1,:,:) = GET_INPUT_FIELD(IMY_PROC, IGPTOTG, IGPBLKS, 1) ALLOCATE(ZSPSC3B(1,ISPEC2,1)) CALL DIR_TRANS(PGP3B=ZGP3B, PSPSC3B=ZSPSC3B, KPROMA=JPPROMA) ! Check only the (0,0) mode (global mean) is one and all the rest are zero IF (HAVE_M0_MODE()) THEN KRET = MERGE(0, 1, APPROX_EQ(ZSPSC3B(1,1,1), 1.0_JPRB) .AND. & & ALL(APPROX_EQ(ZSPSC3B(1,2:,1), 0.0_JPRB))) ELSE KRET = MERGE(0, 1, ALL(APPROX_EQ(ZSPSC3B, 0.0_JPRB))) ENDIF IF (LUSE_MPI) CALL MPL_ALLREDUCE(KRET, CDOPER="MAX") ! Tear down everything DEALLOCATE(ZSPSC3B, ZGP3B) CALL CLEANUP_TEST END FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_2_PGP3B_1 !--------------------------------------------------------------------------------------------------- ! Test DIR_TRANS with call mode 2 and 1-level wind fields INTEGER FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_2_WIND_1() RESULT(KRET) BIND(C) REAL(KIND=JPRB), ALLOCATABLE :: ZGPUV(:,:,:,:), ZSPVOR(:,:), ZSPDIV(:,:) INTEGER(KIND=JPIM) :: ISPEC2, IGPTOTG, IGPTOT, IMY_PROC, IGPBLKS, I_REGIONS_NS, I_REGIONS_EW REAL(KIND=JPRB) :: ZCORRECT_VORTICITY_VALUE ! Set up everything CALL SETUP_TEST(ISPEC2, IGPTOTG, IGPTOT, IGPBLKS, IMY_PROC, I_REGIONS_NS, I_REGIONS_EW) ALLOCATE(ZGPUV(JPPROMA,1,2,IGPBLKS)) ZGPUV(:,1,:,:) = ROTATIONAL_WIND(IGPBLKS, I_REGIONS_NS, I_REGIONS_EW) ALLOCATE(ZSPVOR(1,ISPEC2)) ALLOCATE(ZSPDIV(1,ISPEC2)) CALL DIR_TRANS(PGPUV=ZGPUV, PSPVOR=ZSPVOR, PSPDIV=ZSPDIV, KPROMA=JPPROMA) IF (HAVE_M0_MODE()) THEN ! epsilon_{m=0}^{n=1} = sqrt((n^2 - m^2)/(4n^2 - 1)) = sqrt(1/3) ZCORRECT_VORTICITY_VALUE = 2.0_JPRB * SQRT(1.0_JPRB / 3.0_JPRB) / PPEARTH_RADIUS ! Check all criteria KRET = 0 ! Check divergence is all zero IF (ANY(.NOT. APPROX_EQ(ZSPDIV, 0.0_JPRB))) KRET = 1 ! Check all irrelevant vorticity modes are zero IF (ANY(.NOT. APPROX_EQ(ZSPVOR(1,1:2), 0.0_JPRB))) KRET = 1 ! Check selected harmonic has the correct value IF (.NOT. APPROX_EQ(ZSPVOR(1,3), ZCORRECT_VORTICITY_VALUE)) KRET = 1 ELSE KRET = MERGE(0, 1, ALL(APPROX_EQ(ZSPVOR, 0.0_JPRB) .AND. ALL(APPROX_EQ(ZSPDIV, 0.0_JPRB)))) ENDIF IF (LUSE_MPI) CALL MPL_ALLREDUCE(KRET, CDOPER="MAX") ! Tear down everything DEALLOCATE(ZSPDIV, ZSPVOR, ZGPUV) CALL CLEANUP_TEST END FUNCTION ECTRANS_TEST_TRANS_API_DIR_TRANS_CALL_MODE_2_WIND_1 !--------------------------------------------------------------------------------------------------- END MODULE DIR_TRANS_TEST_SUITE ectrans-1.8.0/tests/trans/api/dir_trans/CMakeLists.txt0000664000175000017500000000215115174631767023152 0ustar alastairalastair# (C) Copyright 2025- ECMWF. # # 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. # API tests for DIR_TRANS # Define list of DIR_TRANS tests set( test_list ectrans_test_trans_api_dir_trans_call_mode_1_scalar_1 ectrans_test_trans_api_dir_trans_call_mode_1_wind_1 ectrans_test_trans_api_dir_trans_call_mode_1_wind_1_scalar_1 ectrans_test_trans_api_dir_trans_call_mode_2_pgp3a_1 ectrans_test_trans_api_dir_trans_call_mode_2_pgp3b_1 ectrans_test_trans_api_dir_trans_call_mode_2_wind_1 ) # Declare tests that WILL_FAIL set( will_fail_list ) generate_api_test_suite( SUITE_NAME dir_trans_test_suite TESTS ${test_list} WILL_FAIL_LIST ${will_fail_list} MPIxOMPS 0x1 0x8 1x1 1x8 2x1 2x8 BACKENDS cpu_sp cpu_dp gpu_sp gpu_dp ) ectrans-1.8.0/tests/trans/api/vordiv_to_uv/0000775000175000017500000000000015174631767021153 5ustar alastairalastairectrans-1.8.0/tests/trans/api/vordiv_to_uv/vordiv_to_uv_test_suite.F900000664000175000017500000000464515174631767026441 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! 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. MODULE VORDIV_TO_UV_TEST_SUITE USE PARKIND1, ONLY: JPIM, JPRB, JPRD IMPLICIT NONE #include "setup_trans0.h" #include "vordiv_to_uv.h" #include "trans_end.h" LOGICAL :: LUSE_MPI INTEGER(KIND=JPIM) :: NPROC CONTAINS !--------------------------------------------------------------------------------------------------- ! Setup fixture SUBROUTINE SETUP_TEST() USE UTIL, ONLY: DETECT_MPIRUN, ENABLE_FPE USE MPL_MODULE, ONLY: MPL_INIT, MPL_NPROC ! Set up MPI LUSE_MPI = DETECT_MPIRUN() IF (LUSE_MPI) THEN CALL MPL_INIT NPROC = MPL_NPROC() ELSE NPROC = 1 ENDIF CALL ENABLE_FPE() ! Can be disabled by setting ECTRANS_TEST_ENABLE_FPE environment variable to "0" CALL SETUP_TRANS0(LDMPOFF=.NOT. LUSE_MPI, KPRGPNS=NPROC, KPRGPEW=1, KPRTRW=NPROC) END SUBROUTINE SETUP_TEST !--------------------------------------------------------------------------------------------------- ! Teardown fixture SUBROUTINE END_TEST USE MPL_MODULE, ONLY: MPL_END CALL TRANS_END IF (LUSE_MPI) THEN CALL MPL_END(LDMEMINFO=.FALSE.) ENDIF END SUBROUTINE END_TEST !--------------------------------------------------------------------------------------------------- INTEGER FUNCTION ECTRANS_TEST_TRANS_API_VORDIV_TO_UV_T1() RESULT(RET) BIND(C) INTEGER(KIND=JPIM), PARAMETER :: TRUNCATION = 1 INTEGER(KIND=JPIM), PARAMETER :: NFLD = 1 INTEGER(KIND=JPIM), PARAMETER :: NSPEC2 = (TRUNCATION + 1) * (TRUNCATION + 2) REAL(KIND=JPRB) :: RSPVOR(NFLD, NSPEC2) REAL(KIND=JPRB) :: RSPDIV(NFLD, NSPEC2) REAL(KIND=JPRB) :: RSPU(NFLD, NSPEC2) REAL(KIND=JPRB) :: RSPV(NFLD, NSPEC2) RSPVOR = 1.0_JPRB RSPDIV = 1.0_JPRB CALL SETUP_TEST CALL VORDIV_TO_UV(PSPVOR=RSPVOR, PSPDIV=RSPDIV, PSPU=RSPU, PSPV=RSPV, KSMAX=TRUNCATION) ! RSPU and RSPV contain NaNs if FPE trapping is not working. WRITE(0,*) 'PSPU =', RSPU WRITE(0,*) 'PSPV =', RSPV CALL END_TEST RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_VORDIV_TO_UV_T1 !--------------------------------------------------------------------------------------------------- END MODULE VORDIV_TO_UV_TEST_SUITE ectrans-1.8.0/tests/trans/api/vordiv_to_uv/CMakeLists.txt0000664000175000017500000000162215174631767023714 0ustar alastairalastair# (C) Copyright 2025- ECMWF. # # 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. # API tests for VORDIV_TO_UV # Define list of VORDIV_TO_UV tests set( test_list ectrans_test_trans_api_vordiv_to_uv_t1 ) # Declare tests that WILL_FAIL set( will_fail_list ) generate_api_test_suite( SUITE_NAME vordiv_to_uv_test_suite TESTS ${test_list} WILL_FAIL_LIST ${will_fail_list} MPIxOMPS 0x1 0x8 BACKENDS cpu_sp cpu_dp EXCLUDES ) # The backends gpu_sp gpu_dp are not yet supported in vordiv_to_uv ectrans-1.8.0/tests/trans/api/setup_trans0/0000775000175000017500000000000015174631767021055 5ustar alastairalastairectrans-1.8.0/tests/trans/api/setup_trans0/setup_trans0_test_suite.F900000664000175000017500000000330315174631767026233 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! 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. MODULE SETUP_TRANS0_TEST_SUITE IMPLICIT NONE #include "setup_trans0.h" CONTAINS !--------------------------------------------------------------------------------------------------- ! NOTE: SETUP_TRANS0 hardly has any error-prone code - it mostly just sets module variables ! Hence, the only logic we test here is the equal regions initialisation ! For the real tests of initialisation, check the suite for SETUP_TRANS !--------------------------------------------------------------------------------------------------- ! Test SETUP_TRANS0 with equal regions enabled INTEGER FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS0_EQ_REGIONS() RESULT(RET) BIND(C) USE UTIL, ONLY: DETECT_MPIRUN USE MPL_MODULE, ONLY: MPL_INIT, MPL_NPROC, MPL_END USE EC_PARKIND, ONLY: JPIM LOGICAL :: LUSE_MPI INTEGER(KIND=JPIM) :: NPROC LUSE_MPI = DETECT_MPIRUN() IF (LUSE_MPI) THEN CALL MPL_INIT NPROC = MPL_NPROC() ELSE NPROC = 1 ENDIF CALL SETUP_TRANS0(LDMPOFF=.NOT. LUSE_MPI, LDEQ_REGIONS=.TRUE., KPRGPNS=NPROC, KPRGPEW=1, & & KPRTRW=NPROC) IF (LUSE_MPI) THEN CALL MPL_END(LDMEMINFO=.FALSE.) ENDIF RET = 0 END FUNCTION ECTRANS_TEST_TRANS_API_SETUP_TRANS0_EQ_REGIONS !--------------------------------------------------------------------------------------------------- END MODULE SETUP_TRANS0_TEST_SUITE ectrans-1.8.0/tests/trans/api/setup_trans0/CMakeLists.txt0000664000175000017500000000155315174631767023621 0ustar alastairalastair# (C) Copyright 2025- ECMWF. # # 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. # API tests for SETUP_TRANS0 # Define list of SETUP_TRANS0 tests set( test_list ectrans_test_trans_api_setup_trans0_eq_regions ) # Define additional list setting tests that WILL_FAIL set( will_fail_list "" # None yet ) generate_api_test_suite( SUITE_NAME setup_trans0_test_suite TESTS ${test_list} WILL_FAIL_LIST ${will_fail_list} MPIxOMPS "0x1" "0x8" "1x1" "1x8" "2x1" "2x8" BACKENDS _ ) ectrans-1.8.0/tests/trans/api/util.F900000664000175000017500000000334515174631767017670 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! ! 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. MODULE UTIL IMPLICIT NONE PRIVATE PUBLIC :: DETECT_MPIRUN, ENABLE_FPE CONTAINS LOGICAL FUNCTION DETECT_MPIRUN() USE EC_ENV_MOD, ONLY : EC_PUTENV INTEGER :: ILEN CHARACTER(LEN=32), DIMENSION(4) :: CMPIRUN_DETECT CHARACTER(LEN=4) :: CLENV INTEGER :: IVAR ! Environment variables that are set when mpirun, srun, aprun, ... are used CMPIRUN_DETECT(1) = 'OMPI_COMM_WORLD_SIZE' ! OPENMPI CMPIRUN_DETECT(2) = 'ALPS_APP_PE' ! CRAY PE CMPIRUN_DETECT(3) = 'PMI_SIZE' ! INTEL CMPIRUN_DETECT(4) = 'SLURM_NTASKS' ! SLURM DETECT_MPIRUN = .FALSE. DO IVAR = 1, 4 CALL GET_ENVIRONMENT_VARIABLE(NAME=TRIM(CMPIRUN_DETECT(IVAR)), LENGTH=ILEN) IF (ILEN > 0) THEN DETECT_MPIRUN = .TRUE. EXIT ! Break ENDIF ENDDO CALL GET_ENVIRONMENT_VARIABLE(NAME="ECTRANS_USE_MPI", VALUE=CLENV, LENGTH=ILEN ) IF (ILEN > 0) THEN DETECT_MPIRUN = .TRUE. IF (TRIM(CLENV) == "0" .OR. TRIM(CLENV) == "OFF" .OR. TRIM(CLENV) == "OFF" & & .OR. TRIM(CLENV) == "F") THEN DETECT_MPIRUN = .FALSE. ENDIF CALL EC_PUTENV("DR_HOOK_ASSERT_MPI_INITIALIZED=0", OVERWRITE=.TRUE.) ENDIF END FUNCTION SUBROUTINE ENABLE_FPE() INTERFACE SUBROUTINE ECTRANS_TEST_ENABLE_FPE() BIND(C) END SUBROUTINE ECTRANS_TEST_ENABLE_FPE END INTERFACE CALL ECTRANS_TEST_ENABLE_FPE() END SUBROUTINE ENABLE_FPE END MODULE UTILectrans-1.8.0/tests/trans/api/CMakeLists.txt0000664000175000017500000001264715174631767021200 0ustar alastairalastair# (C) Copyright 2025- ECMWF. # # 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. # Check whether we have feenableexcept and fedisableexcept for controlling individual floating-point exceptions cmake_push_check_state(RESET) include(CheckSymbolExists) set(CMAKE_REQUIRED_DEFINITIONS -D_GNU_SOURCE) if(UNIX) set(CMAKE_REQUIRED_LIBRARIES m) endif() check_symbol_exists(feenableexcept "fenv.h" HAVE_FEENABLEEXCEPT) check_symbol_exists(fedisableexcept "fenv.h" HAVE_FEDISABLEEXCEPT) if( HAVE_FEENABLEEXCEPT ) set( HAVE_FEENABLEEXCEPT 1 ) else() set( HAVE_FEENABLEEXCEPT 0 ) endif() if( HAVE_FEDISABLEEXCEPT ) set( HAVE_FEDISABLEEXCEPT 1 ) else() set( HAVE_FEDISABLEEXCEPT 0 ) endif() cmake_pop_check_state() # Function for generating a suite of API tests for one external subroutine using CMake's # create_test_sourcelist function function( generate_api_test_suite ) set( options ) set( oneValueArgs SUITE_NAME ) set( multiValueArgs TESTS WILL_FAIL_LIST MPIxOMPS BACKENDS EXCLUDES ) cmake_parse_arguments( _PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN} ) set( suite_name ${_PAR_SUITE_NAME} ) set( tests ${_PAR_TESTS} ) set( will_fail_list ${_PAR_WILL_FAIL_LIST} ) set( mpixomps ${_PAR_MPIxOMPS} ) set( backends ${_PAR_BACKENDS} ) set( excludes ${_PAR_EXCLUDES} ) # Add API tests for this suite, with a separate driver executable for each backend foreach( backend ${backends} ) # Don't include tests which aren't supported by this build if( (backend MATCHES "cpu" AND NOT HAVE_CPU) OR (backend MATCHES "gpu" AND NOT HAVE_GPU) ) continue() endif() if( backend MATCHES "sp" AND NOT HAVE_SINGLE_PRECISION ) continue() endif() if( backend MATCHES "dp" AND NOT HAVE_DOUBLE_PRECISION ) continue() endif() # SETUP_TRANS0 is precision and platform-agnostic if( suite_name STREQUAL setup_trans0_test_suite ) set( libs ectrans_common ) set( suffix "" ) else() if( backend MATCHES "cpu" ) set( platform_tag "" ) # The CPU library doesn't have a suffix elseif( backend MATCHES "gpu" ) set( platform_tag "_gpu" ) endif() if( backend MATCHES "sp" ) set( precision "sp" ) elseif( backend MATCHES "dp" ) set( precision "dp" ) endif() set( libs trans${platform_tag}_${precision} ) set( suffix "_${backend}" ) endif() # Create test suite driver executable encapsulating all tests for this suite at this precision create_test_sourcelist( _ ${suite_name}${suffix}.c ${tests} ) ecbuild_add_executable( TARGET ${suite_name}${suffix} SOURCES ${suite_name}${suffix}.c ${suite_name}.F90 ${CMAKE_CURRENT_SOURCE_DIR}/../util.F90 ${CMAKE_CURRENT_SOURCE_DIR}/../fpe_trapping.cc LINKER_LANGUAGE Fortran LIBS ${libs} DEFINITIONS HAVE_FEENABLEEXCEPT=${HAVE_FEENABLEEXCEPT} HAVE_FEDISABLEEXCEPT=${HAVE_FEDISABLEEXCEPT} ) # Prevent the Fortran runtime from trying to provide a main program target_link_options( ${suite_name}${suffix} PRIVATE ${NO_FORTRAN_MAIN_FLAG} ) ecbuild_target_fortran_module_directory( TARGET ${suite_name}${suffix} MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/module/${suite_name}${suffix} ) # Add a test for each MPI x OpenMP configuration foreach( mpixomp ${mpixomps} ) string(REGEX MATCH "^([0-9]+)x([0-9]+)$" _ "${mpixomp}") set(mpi "${CMAKE_MATCH_1}") set(omp "${CMAKE_MATCH_2}") if( (mpi GREATER 0 AND NOT HAVE_MPI) OR (omp GREATER 1 AND NOT HAVE_OMP) ) continue() endif() # Add each test in the test list for this precision and MPI configuration foreach( test ${tests} ) # We don't yet have a good way to handle aborts in ecTrans gracefully, so for now we will # not include will-fail tests if( ${test} IN_LIST will_fail_list ) continue() endif() set( full_test_name ${test}${suffix}_mpi${mpi}xomp${omp} ) # If this test is in the exclusion list, skip it set( skip_test FALSE ) foreach( exclude ${excludes} ) if( full_test_name MATCHES ${exclude} ) set( skip_test TRUE ) endif() endforeach() if( skip_test ) continue() endif() ecbuild_add_test( TARGET ${full_test_name} COMMAND ${suite_name}${suffix} ARGS ${test} MPI ${mpi} OMP ${omp} ) # Declare that this test should fail if( ${test} IN_LIST will_fail_list ) set_property( TEST ${full_test_name} PROPERTY WILL_FAIL TRUE ) set_property( TEST ${full_test_name} PROPERTY LABELS "will_fail" ) endif() endforeach() endforeach() endforeach() endfunction( generate_api_test_suite ) add_subdirectory( setup_trans0 ) add_subdirectory( setup_trans ) add_subdirectory( dir_trans ) add_subdirectory( vordiv_to_uv ) ectrans-1.8.0/tests/transi/0000775000175000017500000000000015174631767016026 5ustar alastairalastairectrans-1.8.0/tests/transi/transi_test_invtrans_adjoint.c0000664000175000017500000002303515174631767024170 0ustar alastairalastair/* * (C) Crown Copyright 2022 Met Office UK * * 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. */ #include #include #include #include "ectrans/transi.h" #include "transi_test.h" // ---------------------------------------------------------------------------- void test_invtrans_adjoint(int nlon, int nlat, int nsmax) { const unsigned int seed = 123; double adjoint_tol = 1.e-12; printf("test_invtrans_adjoint( nlon=%d, nlat=%d, nsmax=%d )\n",nlon,nlat,nsmax); // ===== Set-up trans ===== struct Trans_t trans; TRANS_CHECK( trans_new(&trans) ); int* nloen = malloc( sizeof(int) * nlat); { int i; for( i=0; i ===== // i.e. adj_value1 = <(rspscalary, rspvory, rspdivy), (rspscalarx, rspvorx, rspdivx)> double adj_value1 = 0.0; if( trans.myproc == 1 ) { int i,j; for( j=0; j ===== // i.e. adj_value2 = double adj_value2 = 0.0; if( trans.myproc == 1 ) { int i,j; for( j=0; j=0 ) { for( i=0; i == if( trans.myproc == 1 ) { printf("[adjval1=%f][adjval2=%f] :\n", adj_value1, adj_value2); ASSERT( fabs(adj_value1 - adj_value2 )/adj_value1 < adjoint_tol ); } // ===== Deallocate arrays and clean up trans ===== free(nloen); free(rgpx); free(rgpy); free(rgpxg); free(rgpyg); free(rspscalarx); free(rspscalary); free(rspscalarxg); free(rspscalaryg); free(rspvorx); free(rspvory); free(rspvorxg); free(rspvoryg); free(rspdivx); free(rspdivy); free(rspdivxg); free(rspdivyg); free(nfrom); free(nto); TRANS_CHECK( trans_delete(&trans) ); } // // ---------------------------------------------------------------------------- int main ( int arc, char **argv ) { trans_use_mpi( test_use_mpi() ); setbuf(stdout,NULL); // unbuffered stdout // The adjoint test works for standard gaussian latitude grid // with no points on the equator or poles. // nsmax = nlat - 1 printf("-----------------------------\n"); test_invtrans_adjoint(8,4,3); TRANS_CHECK( trans_finalize() ); return 0; } ectrans-1.8.0/tests/transi/transi_test_vordiv_to_UV.c0000664000175000017500000000436015174631767023241 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #include #include #include "ectrans/transi.h" #include "transi_test.h" // // Following dummy functions are implementation details // // that don't contribute to this example. They could be // // replaced with grib_api functionality // void read_rspec( struct Trans_t* trans, double* rspec[], int nfld ); int main ( int arc, char **argv ) { trans_use_mpi( test_use_mpi() ); int nfld = 1; int nsmax_array[] = {3};//159,160,1279,1280}; int ni = sizeof(nsmax_array)/sizeof(int); int i,j; for( i=0; i #include #include #include "ectrans/transi.h" #include "transi_test.h" #define print(...) fprintf(stderr, __VA_ARGS__) void print_gp(const char* name, double* array, int nfld, int ngp, int nout); void print_sp(const char* name, double* array, int nfld, int nspec2, int nout); int main ( int arc, char **argv ) { print("ectrans version = %s\n",ectrans_version()); print("Using MPI: %d\n", test_use_mpi()); // Must be done before first trans_setup or trans_init trans_use_mpi( test_use_mpi() ); trans_set_leq_regions(false); trans_set_nprgpew(transi_test_nprgpew()); int nout_gp = 3; int nout_sp = 3; struct Trans_t trans; trans_new(&trans); // lam grid of 20x18 int nx = 20; int ny = 18; double dx = 2500.0; double dy = 2500.0; int tx = (nx-1)/2; int ty = (ny-1)/2; trans_set_resol_lam(&trans, nx, ny, dx, dy); trans_set_trunc_lam(&trans, ty, tx); trans_setup(&trans); if( trans.myproc == 1 ) { print("nproc = %d\n", trans.nproc); print("nx , ny = %d , %d \n", nx, ny); print("tx , ty = %d , %d \n", tx, ty); print("ngptot = %d\n", trans.ngptot); print("ngptotg = %d\n", trans.ngptotg); } // Allocate gridpoint data int nvordiv = 1; int nscalar = 2; int nfld = 2*nvordiv+nscalar; double* rgp = malloc( sizeof(double) * nfld *trans.ngptot ); // Load data on proc 1 double* rgpg = NULL; if( trans.myproc == 1 ) { rgpg = malloc( sizeof(double) * 4*trans.ngptotg ); for (int j=0;j #include #include #include "ectrans/transi.h" #include "transi_test.h" int read_bytes(const char* fp, void** buffer, size_t* size) { FILE *fileptr; fileptr = fopen(fp, "rb"); // Open the file in binary mode fseek(fileptr, 0, SEEK_END); // Jump to the end of the file *size = ftell(fileptr); // Get the current byte offset in the file rewind(fileptr); // Jump back to the beginning of the file *buffer = (void *)malloc((*size+1)*sizeof(char)); // Enough memory for file + \0 fread(*buffer, *size, 1, fileptr); // Read in the entire file fclose(fileptr); return 0; } void test_io() { int N=80; int T=-1; struct Trans_t trans; void* buffer; size_t size; const char* filepath = "TL159_lp"; double start,end; int mem; TRANS_CHECK( trans_new(&trans) ); set_standard_rgg(&trans,N,T); TRANS_CHECK( trans_set_write(&trans,filepath) ); mem = allocated(); start = transi_test_time(); TRANS_CHECK( trans_setup(&trans) ); end=transi_test_time(); print_time("Timing rgg compute+write: ",end-start); print_mem( "Alloc rgg compute+write: ",allocated()-mem); TRANS_CHECK( trans_delete(&trans) ); read_bytes(filepath,&buffer,&size); print_mem( "Cache size:", size); TRANS_CHECK( trans_new(&trans) ); set_standard_rgg(&trans,N,T); TRANS_CHECK( trans_set_cache(&trans,buffer,size) ); mem = allocated(); start = transi_test_time(); TRANS_CHECK( trans_setup(&trans) ); print_time("Timing rgg use cache: ",transi_test_time()-start); print_mem( "Alloc rgg use cache: ",allocated()-mem); TRANS_CHECK( trans_delete(&trans) ); TRANS_CHECK( trans_new(&trans) ); set_standard_rgg(&trans,N,T); TRANS_CHECK( trans_set_read(&trans,filepath) ); mem = allocated(); start = transi_test_time(); TRANS_CHECK( trans_setup(&trans) ); print_time("Timing rgg read: ",transi_test_time()-start); print_mem( "Alloc rgg read: ",allocated()-mem); TRANS_CHECK( trans_delete(&trans) ); free(buffer); } void test_io_lonlat(int nlon, int nlat, int nsmax, int flt) { printf("\nll.%dx%d --- T%d\n",nlon,nlat,nsmax); struct Trans_t trans; void* buffer = NULL; size_t size; char filepath[200]; sprintf(filepath,"T%d_ll.%dx%d_flt%d",nsmax,nlon,nlat,flt); double start; int mem; // int nlon=1280; // int nlat=641; // int nsmax=639; // int nlon=640; // int nlat=321; // int nsmax=319; // int nlon=320; // int nlat=161; // int nsmax=159; bool lonlat=true; int N = (nlat-1)/2; // int nlon=160; // int nlat=81; // int nsmax=79; int nscalar = 2; int nvordiv = 1; int nfld = 2*nvordiv+nscalar; double* rspscalar = NULL; double* rspvor = NULL; double* rspdiv = NULL; double* rgp = NULL; struct InvTrans_t invtrans; // --------------------------------------- // Writing // --------------------------------------- int j; for( j=0; j<1; ++j ) { printf("Writing\n"); TRANS_CHECK( trans_new(&trans) ); trans.flt = flt; if( lonlat ) { TRANS_CHECK( trans_set_resol_lonlat(&trans,nlon,nlat) ); TRANS_CHECK( trans_set_trunc(&trans,nsmax) ); } else { set_standard_rgg(&trans,N,nsmax); } TRANS_CHECK( trans_set_write(&trans,filepath) ); mem = allocated(); start = transi_test_time(); TRANS_CHECK( trans_setup(&trans) ); print_time("Timing lonlat compute+write: ",transi_test_time()-start); print_mem ("Alloc lonlat compute+write: ",allocated()-mem); if( nscalar && rspscalar == NULL ) rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); if( nvordiv && rspvor == NULL && rspdiv == NULL ) { rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); } if( nfld && rgp == NULL ) rgp = malloc( sizeof(double) * nfld * trans.ngptot ); printf("trans_invtrans()...\n"); double start_transform = transi_test_time(); invtrans = new_invtrans(&trans); invtrans.nscalar = nscalar; invtrans.nvordiv = nvordiv; invtrans.rspscalar = rspscalar; invtrans.rspvor = rspvor; invtrans.rspdiv = rspdiv; invtrans.rgp = rgp; TRANS_CHECK( trans_invtrans(&invtrans) ); print_time("trans_invtrans()...done in ",transi_test_time()-start_transform); TRANS_CHECK( trans_delete(&trans) ); } // --------------------------------------- // Use Cache // --------------------------------------- if(1) { printf("Use Cache\n"); read_bytes(filepath,&buffer,&size); print_mem( "Cache size:", size); TRANS_CHECK( trans_new(&trans) ); trans.flt = flt; if( lonlat ) { TRANS_CHECK( trans_set_resol_lonlat(&trans,nlon,nlat) ); TRANS_CHECK( trans_set_trunc(&trans,nsmax) ); } else { set_standard_rgg(&trans,N,nsmax); } TRANS_CHECK( trans_set_cache(&trans,buffer,size) ); mem = allocated(); start = transi_test_time(); TRANS_CHECK( trans_setup(&trans) ); print_time("Timing lonlat use cache: ",transi_test_time()-start); print_mem ("Alloc lonlat use cache: ",allocated()-mem); if( nscalar && rspscalar == NULL ) rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); if( nvordiv && rspvor == NULL && rspdiv == NULL ) { rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); } if( nfld && rgp == NULL ) rgp = malloc( sizeof(double) * nfld * trans.ngptot ); printf("trans_invtrans()...\n"); double start_transform = transi_test_time(); invtrans = new_invtrans(&trans); invtrans.nscalar = nscalar; invtrans.nvordiv = nvordiv; invtrans.rspscalar = rspscalar; invtrans.rspvor = rspvor; invtrans.rspdiv = rspdiv; invtrans.rgp = rgp; TRANS_CHECK( trans_invtrans(&invtrans) ); print_time("trans_invtrans()...done in ",transi_test_time()-start_transform); TRANS_CHECK( trans_delete(&trans) ); } // --------------------------------------- // Reading // --------------------------------------- printf("Reading\n"); TRANS_CHECK( trans_new(&trans) ); trans.flt = flt; if( lonlat ) { TRANS_CHECK( trans_set_resol_lonlat(&trans,nlon,nlat) ); TRANS_CHECK( trans_set_trunc(&trans,nsmax) ); } else { set_standard_rgg(&trans,N,nsmax); } TRANS_CHECK( trans_set_read(&trans,filepath) ); mem = allocated(); start = transi_test_time(); TRANS_CHECK( trans_setup(&trans) ); print_time("Timing lonlat read: ",transi_test_time()-start); print_mem ("Alloc lonlat read: ",allocated()-mem); if( nscalar && rspscalar == NULL ) rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); if( nvordiv && rspvor == NULL && rspdiv == NULL ) { rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); } if( nfld && rgp == NULL ) rgp = malloc( sizeof(double) * nfld * trans.ngptot ); printf("trans_invtrans()...\n"); invtrans = new_invtrans(&trans); invtrans.nscalar = nscalar; invtrans.nvordiv = nvordiv; invtrans.rspscalar = rspscalar; invtrans.rspvor = rspvor; invtrans.rspdiv = rspdiv; invtrans.rgp = rgp; TRANS_CHECK( trans_invtrans(&invtrans) ); printf("trans_invtrans()...done\n"); TRANS_CHECK( trans_delete(&trans) ); // --------------------------------------- if( buffer ) free(buffer); if( rgp ) free(rgp); if( rspscalar ) free(rspscalar); if( rspvor ) free(rspvor); if( rspdiv ) free(rspdiv); } int main ( int arc, char **argv ) { trans_use_mpi( test_use_mpi() ); setbuf(stdout, NULL); TRANS_CHECK( trans_init() ); test_io(); int flt = false; test_io_lonlat(320,161,511,flt); test_io_lonlat(320,161,159,flt); // test_io_lonlat(2400,1201,799,flt); TRANS_CHECK( trans_finalize() ); return 0; } ectrans-1.8.0/tests/transi/transi_test_lonlat_diff_incr.c0000664000175000017500000001171715174631767024114 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #include #include #include #include "ectrans/transi.h" #include "transi_test.h" static bool check_values = true; // ---------------------------------------------------------------------------- void test_sptogp(int nlon, int nlat, int nsmax) { double sptogp_tol = 1.e-6; printf("test_sptogp( nlon=%d, nlat=%d, nsmax=%d )\n",nlon,nlat,nsmax); int nout = 2; struct Trans_t trans; TRANS_CHECK( trans_new(&trans) ); TRANS_CHECK( trans_set_resol_lonlat(&trans,nlon,nlat) ); TRANS_CHECK( trans_set_trunc(&trans,nsmax) ); trans.fft = TRANS_FFTW; trans.flt = 0; TRANS_CHECK( trans_setup(&trans) ); printf("ndgl = %d\n",trans.ndgl); printf("nsmax = %d\n",trans.nsmax); printf("ngptotg = %d\n",trans.ngptotg); ASSERT(trans.ngptotg == nlon*nlat); if( trans.nproc == 1 ) { ASSERT(trans.ngptot == nlon*nlat + nlon*(nlat%2)); } ASSERT(trans.nspec2 == trans.nspec2g); ASSERT( trans.nproc == 1 ); // In case of odd number of latitudes, there is one latitude extra in distributed gridpoints // This can only be checked with nproc==1 // Allocate gridpoint data int nscalar = 1; int nvordiv = 1; int nfld = 2*nvordiv+nscalar; double* rgp = malloc( sizeof(double) * nfld * trans.ngptot ); // Load data on proc 1 double* rgpg = NULL; if( trans.myproc == 1 ) { rgpg = malloc( sizeof(double) * nfld*trans.ngptotg ); } // // Allocate spectral data double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); // Gather spectral field (for fun) int* nto = malloc( sizeof(int) * nfld ); int k; for( k=0; k sptogp_tol ) // printf("error --> rgp[fld=%d][pt=%d] : %f\n",j,i,rgp[j*trans.ngptot+i]); ASSERT( fabs(rgp[j*trans.ngptot+i]) < sptogp_tol ); } } } } printf("trans_gathgrid()\n"); // Gather gridpoint fields struct GathGrid_t gathgrid = new_gathgrid(&trans); gathgrid.rgp = rgp; gathgrid.rgpg = rgpg; gathgrid.nto = nfrom; gathgrid.nfld = nfld; TRANS_CHECK( trans_gathgrid(&gathgrid) ); if( trans.myproc == 1 ) { int i,j; for( j=0; j #include #include #include #include "ectrans/transi.h" #include "transi_test.h" // ---------------------------------------------------------------------------- double randomDouble() { uint64_t r53 = ((uint64_t)(rand()) << 21) ^ (rand() >> 2); return (double)r53 / 9007199254740991.0; // 2^53 - 1 } // ---------------------------------------------------------------------------- void test_lam_dirtrans_adjoint() { double adjoint_tol = 1.e-6; printf("test_lam_dirtrans_adjoint()\n"); struct Trans_t trans; TRANS_CHECK( trans_new(&trans) ); TRANS_CHECK( trans_set_resol_lam(&trans, 20, 18, 2500.0, 2500.0) ); TRANS_CHECK( trans_set_trunc_lam(&trans, 9, 8) ); TRANS_CHECK( trans_setup(&trans) ); TRANS_CHECK( trans_inquire(&trans,"nvalue,mvalue") ); // Number of fields int nscalar = 2; int nvordiv = 1; int nfld = 2*nvordiv+nscalar; // Allocate test data double* rgp1 = calloc( nfld * trans.ngptot, sizeof(double) ); double* rspvor1 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspdiv1 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspscalar1 = calloc( nscalar * trans.nspec2, sizeof(double) ); double* rmeanu1 = calloc( nvordiv, sizeof(double) ); double* rmeanv1 = calloc( nvordiv, sizeof(double) ); double* rgp2 = calloc( nfld * trans.ngptot, sizeof(double) ); double* rspvor2 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspdiv2 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspscalar2 = calloc( nscalar * trans.nspec2, sizeof(double) ); double* rmeanu2 = calloc( nvordiv, sizeof(double) ); double* rmeanv2 = calloc( nvordiv, sizeof(double) ); // Create random grid-point fields for(int j=0; j #include #include #include #include #include "ectrans/transi.h" #include "transi_test.h" int main ( int arc, char **argv ) { int nloen[] = {18,25,36,40,45,54,60,64,72,72,80,90,96,100,108,120,120,128,135,144,144,150,160,160,180,180,180,192,192,200,200,216,216,216,225,225,240,240,240,256,256,256,256,288,288,288,288,288,288,288,288,288,300,300,300,300,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,300,300,300,300,288,288,288,288,288,288,288,288,288,256,256,256,256,240,240,240,225,225,216,216,216,200,200,192,192,180,180,180,160,160,150,144,144,135,128,120,120,108,100,96,90,80,72,72,64,60,54,45,40,36,25,18}; int start = allocated(); print_mem("Initially allocated: ",allocated()-start); if( strcmp(ectrans_version(),"transi/contrib") == 0 ) // equals trans_set_handles_limit(2); else /// Older versions cannot reuse existing handles, so allocate enough. trans_set_handles_limit(3); trans_use_mpi(false); trans_init(); int iter=0; int iter_max=50; int mem_leak=1; //int start_loop = allocated(); for( iter=0; iter #include #include #include #include #include "ectrans/transi.h" #include "transi_test.h" int main ( int arc, char **argv ) { int start = allocated(); print_mem("Initially allocated: ",allocated()-start); if( strcmp(ectrans_version(),"transi/contrib") == 0 ) // equals trans_set_handles_limit(2); else /// Older versions cannot reuse existing handles, so allocate enough. trans_set_handles_limit(3); trans_use_mpi(false); trans_init(); int iter=0; int iter_max=50; int mem_leak=1; //int start_loop = allocated(); for( iter=0; iter #include "transi_test.h" // ----------------------------------------------------------------------------- // IMPLEMENTATIONS int test_use_mpi() { if ( getenv( "TRANS_USE_MPI" ) ) { return atoi( getenv( "TRANS_USE_MPI" ) ); } return 1; } int transi_test_nprgpew() { if ( getenv( "TRANS_NPRGPEW" ) ) { return atoi( getenv( "TRANS_NPRGPEW" ) ); } return 1; } double transi_test_time() { static double time_init = -1; double time_in_secs; struct timeval tbuf; if (gettimeofday(&tbuf,NULL) == -1) perror("transi_test_time"); if (time_init == -1) time_init = (double) tbuf.tv_sec + (tbuf.tv_usec / 1000000.0); time_in_secs = (double) tbuf.tv_sec + (tbuf.tv_usec / 1000000.0) - time_init; return time_in_secs; } void print_time(const char* str,double elapsed) { int msec = elapsed * 1000; printf("%s%d seconds %d milliseconds\n",str, msec/1000, msec%1000); } #ifdef TRANSI_HAVE_MEMORY #include #endif void display_mallinfo(void) { #ifdef TRANSI_HAVE_MEMORY struct mallinfo mi; mi = mallinfo(); printf("Total non-mmapped bytes (arena): %d\n", mi.arena); printf("# of free chunks (ordblks): %d\n", mi.ordblks); printf("# of free fastbin blocks (smblks): %d\n", mi.smblks); printf("# of mapped regions (hblks): %d\n", mi.hblks); printf("Bytes in mapped regions (hblkhd): %d\n", mi.hblkhd); printf("Max. total allocated space (usmblks): %d\n", mi.usmblks); printf("Free bytes held in fastbins (fsmblks): %d\n", mi.fsmblks); printf("Total allocated space (uordblks): %d\n", mi.uordblks); printf("Total free space (fordblks): %d\n", mi.fordblks); printf("Topmost releasable block (keepcost): %d\n", mi.keepcost); #endif } int allocated() { #ifdef TRANSI_HAVE_MEMORY struct mallinfo mi; mi = mallinfo(); return mi.hblkhd + mi.uordblks; #else return 0; #endif } void print_mem(const char* str,const int bytes) { #ifdef TRANSI_HAVE_MEMORY float B, KB, MB; B = bytes; KB = B/1024.; MB = KB/1024.; if( MB > 0.1 ) printf("%s%f MB\n",str,MB); else printf("%s%f KB\n",str,KB); #endif } void set_standard_rgg(struct Trans_t* trans, int N, int T) { if( N==48 ) // TL95 { int nloen[] = {20,25,36,40,45,50,60,60,72,75,80,90,96,100,108,120,120,120,128,135,144,144,160,160,160,160,160,180,180,180,180,180,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,192,180,180,180,180,180,160,160,160,160,160,144,144,135,128,120,120,120,108,100,96,90,80,75,72,60,60,50,45,40,36,25,20}; trans_set_resol(trans,sizeof(nloen)/sizeof(int),nloen); if( T<0 ) trans_set_trunc(trans,95); else trans_set_trunc(trans,T); return; } if( N==80 ) // TL159 { int nloen[] = {18,25,36,40,45,54,60,64,72,72,80,90,96,100,108,120,120,128,135,144,144,150,160,160,180,180,180,192,192,200,200,216,216,216,225,225,240,240,240,256,256,256,256,288,288,288,288,288,288,288,288,288,300,300,300,300,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,320,300,300,300,300,288,288,288,288,288,288,288,288,288,256,256,256,256,240,240,240,225,225,216,216,216,200,200,192,192,180,180,180,160,160,150,144,144,135,128,120,120,108,100,96,90,80,72,72,64,60,54,45,40,36,25,18}; trans_set_resol(trans,sizeof(nloen)/sizeof(int),nloen); if( T<0 ) trans_set_trunc(trans,159); else trans_set_trunc(trans,T); return; } if( N==128 ) // TL255 { int nloen[] = {18,25,36,40,45,50,60,64,72,72,80,90,90,100,108,120,120,125,128,144,144,150,160,160,180,180,180,192,192,200,216,216,216,225,240,240,240,250,250,256,270,270,288,288,288,300,300,320,320,320,320,324,360,360,360,360,360,360,360,375,375,375,375,384,384,400,400,400,400,405,432,432,432,432,432,432,432,450,450,450,450,450,480,480,480,480,480,480,480,480,480,480,486,486,486,500,500,500,500,500,500,500,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,512,500,500,500,500,500,500,500,486,486,486,480,480,480,480,480,480,480,480,480,480,450,450,450,450,450,432,432,432,432,432,432,432,405,400,400,400,400,384,384,375,375,375,375,360,360,360,360,360,360,360,324,320,320,320,320,300,300,288,288,288,270,270,256,250,250,240,240,240,225,216,216,216,200,192,192,180,180,180,160,160,150,144,144,128,125,120,120,108,100,90,90,80,72,72,64,60,50,45,40,36,25,18}; trans_set_resol(trans,sizeof(nloen)/sizeof(int),nloen); if( T<0 ) trans_set_trunc(trans,255); else trans_set_trunc(trans,T); return; } if( N==256 ) // TL511 { int nloen[] = {18,25,32,40,45,50,60,64,72,72,75,81,90,96,100,108,120,120,125,135,144,150,160,160,180,180,180,192,192,200,216,216,216,225,240,240,243,250,256,270,270,288,288,288,300,300,320,320,320,324,360,360,360,360,360,360,375,375,384,384,400,400,400,432,432,432,432,432,450,450,450,480,480,480,480,480,486,500,500,500,512,512,540,540,540,540,540,576,576,576,576,576,576,600,600,600,600,600,640,640,640,640,640,640,640,640,648,675,675,675,675,675,675,720,720,720,720,720,720,720,720,720,729,729,750,750,750,750,750,768,768,768,768,800,800,800,800,800,800,800,800,810,810,864,864,864,864,864,864,864,864,864,864,864,864,864,864,900,900,900,900,900,900,900,900,900,900,900,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,972,972,972,972,972,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1024,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,1000,972,972,972,972,972,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,960,900,900,900,900,900,900,900,900,900,900,900,864,864,864,864,864,864,864,864,864,864,864,864,864,864,810,810,800,800,800,800,800,800,800,800,768,768,768,768,750,750,750,750,750,729,729,720,720,720,720,720,720,720,720,720,675,675,675,675,675,675,648,640,640,640,640,640,640,640,640,600,600,600,600,600,576,576,576,576,576,576,540,540,540,540,540,512,512,500,500,500,486,480,480,480,480,480,450,450,450,432,432,432,432,432,400,400,400,384,384,375,375,360,360,360,360,360,360,324,320,320,320,300,300,288,288,288,270,270,256,250,243,240,240,225,216,216,216,200,192,192,180,180,180,160,160,150,144,135,125,120,120,108,100,96,90,81,75,72,72,64,60,50,45,40,32,25,18}; trans_set_resol(trans,sizeof(nloen)/sizeof(int),nloen); if( T<0 ) trans_set_trunc(trans,511); else trans_set_trunc(trans,T); return; } if( N==640 ) // TL1279 { int nloen[] = {18,25,32,40,45,50,60,60,72,72,75,81,90,90,96,100,108,120,120,125,135,144,150,160,160,180,180,180,192,192,200,216,216,216,225,240,240,243,250,256,270,270,288,288,288,300,300,320,320,320,360,360,360,360,360,360,375,375,384,384,400,400,400,432,432,432,432,450,450,450,480,480,480,480,480,486,500,500,512,512,540,540,540,540,540,576,576,576,576,576,600,600,600,600,640,640,640,640,640,640,640,648,675,675,675,675,720,720,720,720,720,720,720,720,729,750,750,750,750,768,768,768,800,800,800,800,800,810,810,864,864,864,864,864,864,864,864,900,900,900,900,900,900,960,960,960,960,960,960,960,960,960,960,960,972,972,1000,1000,1000,1000,1000,1024,1024,1024,1024,1080,1080,1080,1080,1080,1080,1080,1080,1080,1125,1125,1125,1125,1125,1125,1125,1125,1152,1152,1152,1152,1152,1200,1200,1200,1200,1200,1200,1200,1200,1215,1215,1215,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1296,1296,1350,1350,1350,1350,1350,1350,1350,1350,1350,1350,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1458,1458,1458,1458,1500,1500,1500,1500,1500,1500,1500,1500,1536,1536,1536,1536,1536,1536,1536,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1620,1620,1620,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1920,1920,1920,1920,1920,1920,1920,1920,1920,1920,1920,1944,1944,1944,1944,1944,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2025,2025,2025,2025,2025,2025,2048,2048,2048,2048,2048,2048,2048,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2187,2187,2187,2187,2187,2187,2187,2187,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2430,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2187,2187,2187,2187,2187,2187,2187,2187,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2048,2048,2048,2048,2048,2048,2048,2025,2025,2025,2025,2025,2025,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,1944,1944,1944,1944,1944,1920,1920,1920,1920,1920,1920,1920,1920,1920,1920,1920,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1620,1620,1620,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1536,1536,1536,1536,1536,1536,1536,1500,1500,1500,1500,1500,1500,1500,1500,1458,1458,1458,1458,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1350,1350,1350,1350,1350,1350,1350,1350,1350,1350,1296,1296,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1280,1215,1215,1215,1200,1200,1200,1200,1200,1200,1200,1200,1152,1152,1152,1152,1152,1125,1125,1125,1125,1125,1125,1125,1125,1080,1080,1080,1080,1080,1080,1080,1080,1080,1024,1024,1024,1024,1000,1000,1000,1000,1000,972,972,960,960,960,960,960,960,960,960,960,960,960,900,900,900,900,900,900,864,864,864,864,864,864,864,864,810,810,800,800,800,800,800,768,768,768,750,750,750,750,729,720,720,720,720,720,720,720,720,675,675,675,675,648,640,640,640,640,640,640,640,600,600,600,600,576,576,576,576,576,540,540,540,540,540,512,512,500,500,486,480,480,480,480,480,450,450,450,432,432,432,432,400,400,400,384,384,375,375,360,360,360,360,360,360,320,320,320,300,300,288,288,288,270,270,256,250,243,240,240,225,216,216,216,200,192,192,180,180,180,160,160,150,144,135,125,120,120,108,100,96,90,90,81,75,72,72,60,60,50,45,40,32,25,18}; trans_set_resol(trans,sizeof(nloen)/sizeof(int),nloen); if( T<0 ) trans_set_trunc(trans,1279); else trans_set_trunc(trans,T); return; } if( N==1024 ) // TL2047 { int nloen[] = {18,25,32,40,45,50,60,64,72,72,75,81,90,96,96,108,108,120,120,125,125,135,144,150,160,160,180,180,180,192,192,200,216,216,225,225,240,240,243,250,256,270,270,288,288,288,300,300,320,320,320,360,360,360,360,360,360,375,375,384,384,400,400,405,432,432,432,432,450,450,450,480,480,480,480,480,486,500,500,512,512,540,540,540,540,576,576,576,576,576,576,600,600,600,600,625,625,625,625,640,640,648,675,675,675,675,675,720,720,720,720,720,720,720,729,750,750,750,750,768,768,800,800,800,800,800,800,810,864,864,864,864,864,864,864,864,864,900,900,900,900,900,900,960,960,960,960,960,960,960,960,960,972,972,1000,1000,1000,1000,1000,1024,1024,1024,1024,1080,1080,1080,1080,1080,1080,1080,1080,1080,1125,1125,1125,1125,1125,1125,1125,1152,1152,1152,1152,1152,1200,1200,1200,1200,1200,1200,1200,1215,1215,1215,1250,1250,1250,1250,1250,1250,1280,1280,1280,1280,1280,1296,1296,1350,1350,1350,1350,1350,1350,1350,1350,1350,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1458,1458,1458,1500,1500,1500,1500,1500,1500,1500,1500,1536,1536,1536,1536,1536,1536,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1620,1620,1620,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1920,1920,1920,1920,1920,1920,1920,1920,1944,1944,1944,1944,1944,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,2025,2025,2025,2025,2048,2048,2048,2048,2048,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2187,2187,2187,2187,2187,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2430,2430,2430,2430,2430,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2592,2592,2592,2592,2592,2592,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2916,2916,2916,2916,2916,2916,2916,2916,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3240,3240,3240,3240,3240,3240,3240,3240,3240,3240,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4096,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4050,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,4000,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3888,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3840,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3750,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3645,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3600,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3456,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3375,3240,3240,3240,3240,3240,3240,3240,3240,3240,3240,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3200,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3125,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3072,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,3000,2916,2916,2916,2916,2916,2916,2916,2916,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2880,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2700,2592,2592,2592,2592,2592,2592,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2560,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2500,2430,2430,2430,2430,2430,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2400,2304,2304,2304,2304,2304,2304,2304,2304,2304,2304,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2250,2187,2187,2187,2187,2187,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2160,2048,2048,2048,2048,2048,2025,2025,2025,2025,2000,2000,2000,2000,2000,2000,2000,2000,2000,2000,1944,1944,1944,1944,1944,1920,1920,1920,1920,1920,1920,1920,1920,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1875,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1800,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1728,1620,1620,1620,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1600,1536,1536,1536,1536,1536,1536,1500,1500,1500,1500,1500,1500,1500,1500,1458,1458,1458,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1440,1350,1350,1350,1350,1350,1350,1350,1350,1350,1296,1296,1280,1280,1280,1280,1280,1250,1250,1250,1250,1250,1250,1215,1215,1215,1200,1200,1200,1200,1200,1200,1200,1152,1152,1152,1152,1152,1125,1125,1125,1125,1125,1125,1125,1080,1080,1080,1080,1080,1080,1080,1080,1080,1024,1024,1024,1024,1000,1000,1000,1000,1000,972,972,960,960,960,960,960,960,960,960,960,900,900,900,900,900,900,864,864,864,864,864,864,864,864,864,810,800,800,800,800,800,800,768,768,750,750,750,750,729,720,720,720,720,720,720,720,675,675,675,675,675,648,640,640,625,625,625,625,600,600,600,600,576,576,576,576,576,576,540,540,540,540,512,512,500,500,486,480,480,480,480,480,450,450,450,432,432,432,432,405,400,400,384,384,375,375,360,360,360,360,360,360,320,320,320,300,300,288,288,288,270,270,256,250,243,240,240,225,225,216,216,200,192,192,180,180,180,160,160,150,144,135,125,125,120,120,108,108,96,96,90,81,75,72,72,64,60,50,45,40,32,25,18}; trans_set_resol(trans,sizeof(nloen)/sizeof(int),nloen); if( T<0 ) trans_set_trunc(trans,2047); else trans_set_trunc(trans,T); return; } } ectrans-1.8.0/tests/transi/transi_test_lonlat.c0000664000175000017500000001771315174631767022113 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #include #include #include #include "ectrans/transi.h" #include "transi_test.h" static bool check_values = false; // ---------------------------------------------------------------------------- void test_gptosptogp(int nlon, int nlat, int nsmax) { double gptosp_tol = 1.e-6; double sptogp_tol = 1.e-6; printf("test_gptosptogp( nlon=%d, nlat=%d, nsmax=%d )\n",nlon,nlat,nsmax); int nout = 2; struct Trans_t trans; TRANS_CHECK( trans_new(&trans) ); TRANS_CHECK( trans_set_resol_lonlat(&trans,nlon,nlat) ); TRANS_CHECK( trans_set_trunc(&trans,nsmax) ); //set_standard_rgg(&trans,(nlat-1)/2,nsmax); trans.fft = TRANS_FFTW; trans.flt = 0; TRANS_CHECK( trans_setup(&trans) ); printf("ndgl = %d\n",trans.ndgl); printf("nsmax = %d\n",trans.nsmax); printf("ngptotg = %d\n",trans.ngptotg); ASSERT(trans.ngptotg == nlon*nlat); // In case of odd number of latitudes, there is one latitude extra in distributed gridpoints // This can only be checked with nproc==1 if( trans.nproc == 1 ) ASSERT(trans.ngptot == nlon*nlat + nlon*(nlat%2)); // Allocate gridpoint data int nscalar = 2; int nvordiv = 1; int nfld = 2*nvordiv+nscalar; double* rgp = malloc( sizeof(double) * nfld * trans.ngptot ); // Load data on proc 1 double* rgpg = NULL; if( trans.myproc == 1 ) { rgpg = malloc( sizeof(double) * nfld*trans.ngptotg ); int i; for( i=0; i=0 ) { for( i=0; i gptosp_tol) printf("error --> rgp[fld=%d][pt=%d] : %f instead of %d\n",j,i,rgp[j*trans.ngptot+i],(j+1)); ASSERT( fabs(rgp[j*trans.ngptot+i]-(j+1)) < gptosp_tol); } } } } // Allocate spectral data double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); // Direct Transform printf("trans_dirtrans()\n"); struct DirTrans_t dirtrans = new_dirtrans(&trans); dirtrans.nscalar = nscalar; dirtrans.nvordiv = nvordiv; dirtrans.rgp = rgp; dirtrans.rspscalar = rspscalar; dirtrans.rspvor = rspvor; dirtrans.rspdiv = rspdiv; TRANS_CHECK( trans_dirtrans(&dirtrans) ); if( trans.myproc == 1 ) { int i,j; for( j=0; j=2 && check_values ) { for( i=1; i gptosp_tol ) printf("error --> rspscalar[fld=%d][wave=%d] : %f\n",j,i,rspscalar[i*nscalar+j]); } } } } // Gather spectral field (for fun) int* nto = malloc( sizeof(int) * nscalar ); nto[0] = 1; nto[1] = 1; double* rspscalarg = NULL; if( trans.myproc == 1 ) rspscalarg = malloc( sizeof(double) * nscalar*trans.nspec2g ); printf("trans_gathspec()\n"); struct GathSpec_t gathspec = new_gathspec(&trans); gathspec.rspec = rspscalar; gathspec.rspecg = rspscalarg; gathspec.nfld = nscalar; gathspec.nto = nto; TRANS_CHECK( trans_gathspec(&gathspec) ); if( trans.myproc == 1 ) { int i,j; for( j=0; j gptosp_tol ) printf("error -> rspscalarg[fld=%d][wave=%d] : %f\n",j,i,rspscalarg[i*nscalar+j]); } } } } printf("trans_distspec()\n"); // Distribute spectral field (for fun) struct DistSpec_t distspec = new_distspec(&trans); distspec.rspec = rspscalar; distspec.rspecg = rspscalarg; distspec.nfld = nscalar; distspec.nfrom = nto; TRANS_CHECK( trans_distspec(&distspec) ); printf("trans_invtrans()\n"); // Inverse Transform struct InvTrans_t invtrans = new_invtrans(&trans); invtrans.nscalar = nscalar; invtrans.nvordiv = nvordiv; invtrans.rspscalar = rspscalar; invtrans.rspvor = rspvor; invtrans.rspdiv = rspdiv; invtrans.rgp = rgp; TRANS_CHECK( trans_invtrans(&invtrans) ); if( trans.myproc == 1 ) { int i,j; for( j=0; j= 2 && check_values ) { for( i=0; i sptogp_tol ) printf("error --> rgp[fld=%d][pt=%d] : %f\n",j,i,rgp[j*trans.ngptot+i]); ASSERT( fabs(rgp[j*trans.ngptot+i] - (j+1) )/(double)(j+1) < sptogp_tol ); } } } } printf("trans_gathgrid()\n"); // Gather gridpoint fields struct GathGrid_t gathgrid = new_gathgrid(&trans); gathgrid.rgp = rgp; gathgrid.rgpg = rgpg; gathgrid.nto = nfrom; gathgrid.nfld = nfld; TRANS_CHECK( trans_gathgrid(&gathgrid) ); if( trans.myproc == 1 ) { int i,j; for( j=0; j=2 && check_values ) { for( i=0; i sptogp_tol ) printf("error --> rgpg[fld=%d][pt=%d] : %f\n",j,i,rgpg[j*trans.ngptotg+i]); } } } } // Deallocate arrays free(rgp); free(rgpg); free(rspscalar); free(rspscalarg); free(rspvor); free(rspdiv); free(nfrom); free(nto); TRANS_CHECK( trans_delete(&trans) ); } // ---------------------------------------------------------------------------- int main ( int arc, char **argv ) { trans_use_mpi( test_use_mpi() ); setbuf(stdout,NULL); // unbuffered stdout // test_gptosptogp(144,73,1279); // As IVER does it // nsmax = (2*(nlat-1)-1)/2; printf("-----------------------------\n"); test_gptosptogp(320,161,159); printf("-----------------------------\n"); test_gptosptogp(320,161,255); printf("-----------------------------\n"); test_gptosptogp(320,161, 95); printf("-----------------------------\n"); test_gptosptogp(640,161,159); printf("-----------------------------\n"); test_gptosptogp(160,161,159); printf("-----------------------------\n"); TRANS_CHECK( trans_finalize() ); return 0; } ectrans-1.8.0/tests/transi/transi_test_dirtrans_adjoint.c0000664000175000017500000002333515174631767024155 0ustar alastairalastair/* * (C) Crown Copyright 2022 Met Office (UK) * * 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. */ #include #include #include #include "ectrans/transi.h" #include "transi_test.h" // ---------------------------------------------------------------------------- void test_dirtrans_adjoint(int nlon, int nlat, int nsmax) { const unsigned int seed = 123; srand(seed); const double adjoint_tol = 1.e-12; printf("test_dirtrans_adjoint( nlon=%d, nlat=%d, nsmax=%d )\n",nlon,nlat,nsmax); struct Trans_t trans; TRANS_CHECK( trans_new(&trans) ); int* nloen = malloc( sizeof(int) * nlat); { int i; for( i=0; i ===== // i.e. adj_value1 = <(rspscalary, rspvory, rspdivy), (rspscalarx, rspvorx, rspdivx)> double adj_value1 = 0.0; if( trans.myproc == 1 ) { int i,j; for( j=0; j ===== // i.e. adj_value2 = double adj_value2 = 0.0; if( trans.myproc == 1 ) { int i,j; for( j=0; j=0 ) { for( i=0; i == if( trans.myproc == 1 ) { printf("rgpg[adjval1=%g][adjval2=%g] :\n", adj_value1, adj_value2); ASSERT( fabs(adj_value1 - adj_value2 )/fabs(adj_value1) < adjoint_tol ); } // Deallocate arrays free(nloen); free(rgpx); free(rgpy); free(rgpxg); free(rgpyg); free(rspscalarx); free(rspscalary); free(rspscalarxg); free(rspscalaryg); free(rspvorx); free(rspvory); free(rspvorxg); free(rspvoryg); free(rspdivx); free(rspdivy); free(rspdivxg); free(rspdivyg); free(nfrom); free(nto); TRANS_CHECK( trans_delete(&trans) ); } // // ---------------------------------------------------------------------------- int main ( int arc, char **argv ) { trans_use_mpi( test_use_mpi() ); setbuf(stdout,NULL); // unbuffered stdout // The adjoint test works for standard gaussian latitude grid // with no points on the equator or poles. // nsmax = nlat - 1 printf("-----------------------------\n"); test_dirtrans_adjoint(8,4,3); TRANS_CHECK( trans_finalize() ); return 0; } ectrans-1.8.0/tests/transi/transi_test_program.c0000664000175000017500000002504715174631767022270 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #include #include #include #include "ectrans/transi.h" #include "transi_test.h" void read_grid(struct Trans_t*); int main ( int arc, char **argv ) { #ifdef GPU_VERSION fprintf(stderr, "transi_test_program GPU VERSION\n"); #else fprintf(stderr, "transi_test_program CPU VERSION\n"); #endif fprintf(stderr,"start\n"); fprintf(stderr,"ectrans version int = %d\n",ectrans_version_int()); fprintf(stderr,"ectrans version = %s\n",ectrans_version()); fprintf(stderr,"ectrans version str = %s\n",ectrans_version_str()); fprintf(stderr,"ectrans git sha1 [0:7] = %s\n",ectrans_git_sha1_abbrev(7)); fprintf(stderr,"ectrans git sha1 [0:12] = %s\n",ectrans_git_sha1_abbrev(12)); fprintf(stderr,"ectrans git sha1 = %s\n",ectrans_git_sha1()); fprintf(stderr,"Using MPI: %d\n", test_use_mpi()); trans_use_mpi( test_use_mpi() ); fprintf(stderr,"trans_new\n"); int nout = 3; struct Trans_t trans; trans_new(&trans); fprintf(stderr,"trans_new done\n"); read_grid(&trans); fprintf(stderr,"trans_setup\n"); trans_setup(&trans); fprintf(stderr,"trans_setup done\n"); trans_inquire(&trans,"numpp,ngptotl,nmyms,nasm0,npossp,nptrms,nallms,ndim0g,nvalue"); trans_inquire(&trans,"nfrstlat,nlstlat,nptrlat,nptrfrstlat,nptrlstlat,nsta,nonl,ldsplitlat"); trans_inquire(&trans,"nultpp,nptrls,nnmeng"); trans_inquire(&trans,"rmu,rgw,npms,rlapin,ndglu"); //Check values of numpp if( trans.myproc == 1 ) { fprintf(stderr,"nprtrw = %d\n",trans.nprtrw); int i; for( i=0; i 1.e-5) fprintf(stderr,"rgp[%d][%d] : %f\n",j,i,rgp[j*trans.ngptot+i]); } } } // Allocate spectral data double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); // Direct Transform fprintf(stderr,"dirtrans\n"); struct DirTrans_t dirtrans = new_dirtrans(&trans); dirtrans.nscalar = nscalar; dirtrans.nvordiv = nvordiv; dirtrans.rgp = rgp; dirtrans.rspscalar = rspscalar; dirtrans.rspvor = rspvor; dirtrans.rspdiv = rspdiv; trans_dirtrans(&dirtrans); fprintf(stderr,"dirtrans done\n"); if( trans.myproc == 1 ) { int i,j; for( j=0; j 1.e-5) fprintf(stderr,"rspscalar[%d][%d] : %f\n",j,i,rspscalar[i*nscalar+j]); } } } #ifndef GPU_VERSION // Allocate fields for u*cos(theta) and v*cos(theta) double* rspu = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); // Convert vorticity & divergence to u*cos(theta) & v*cos(theta) fprintf(stderr,"Converting spectral vorticity-divergence to u*cos(lat)-v*cos(lat)...\n"); struct VorDivToUV_t vordiv_to_UV = new_vordiv_to_UV(); vordiv_to_UV.rspvor = rspvor; vordiv_to_UV.rspdiv = rspdiv; vordiv_to_UV.rspu = rspu; vordiv_to_UV.rspv = rspv; vordiv_to_UV.nfld = nvordiv; vordiv_to_UV.ncoeff = trans.nspec2; vordiv_to_UV.nsmax = trans.nsmax; trans_vordiv_to_UV(&vordiv_to_UV); fprintf(stderr,"Converting spectral vorticity-divergence to u*cos(lat)-v*cos(lat)...done\n"); #endif // Gather spectral field (for fun) int* nto = malloc( sizeof(int) * nscalar ); nto[0] = 1; nto[1] = 1; double* rspscalarg = NULL; if( trans.myproc == 1 ) rspscalarg = malloc( sizeof(double) * nscalar*trans.nspec2g ); struct GathSpec_t gathspec = new_gathspec(&trans); gathspec.rspec = rspscalar; gathspec.rspecg = rspscalarg; gathspec.nfld = nscalar; gathspec.nto = nto; trans_gathspec(&gathspec); if( trans.myproc == 1 ) { int i,j; for( j=0; j 1.e-5 && i > 0) fprintf(stderr,"rspscalarg[%d][%d] : %f\n",j,i,rspscalarg[i*nscalar+j]); } } } if( trans.myproc == 1 ) { int i,j; for( j=0; j 1.e-5 && i > 0) fprintf(stderr,"rspscalarg[%d][%d] : %f\n",j,i,rspscalarg[i*nscalar+j]); } } } // Allocate fields for u*cos(theta) and v*cos(theta) double* rspvorg = malloc( sizeof(double) * nvordiv*trans.nspec2g ); double* rspdivg = malloc( sizeof(double) * nvordiv*trans.nspec2g ); gathspec = new_gathspec(&trans); gathspec.rspec = rspvor; gathspec.rspecg = rspvorg; gathspec.nfld = nvordiv; gathspec.nto = nto; trans_gathspec(&gathspec); gathspec = new_gathspec(&trans); gathspec.rspec = rspdiv; gathspec.rspecg = rspdivg; gathspec.nfld = nvordiv; gathspec.nto = nto; trans_gathspec(&gathspec); #ifndef GPU_VERSION // Allocate fields for u*cos(theta) and v*cos(theta) double* rspug = malloc( sizeof(double) * nvordiv*trans.nspec2g ); double* rspvg = malloc( sizeof(double) * nvordiv*trans.nspec2g ); // Convert vorticity & divergence to u*cos(theta) & v*cos(theta) fprintf(stderr,"Converting spectral vorticity-divergence to U-V globally...\n"); struct VorDivToUV_t vordiv_to_UV_g = new_vordiv_to_UV(); vordiv_to_UV_g.rspvor = rspvorg; vordiv_to_UV_g.rspdiv = rspdivg; vordiv_to_UV_g.rspu = rspug; vordiv_to_UV_g.rspv = rspvg; vordiv_to_UV_g.nfld = nvordiv; vordiv_to_UV_g.ncoeff = trans.nspec2g; vordiv_to_UV_g.nsmax = trans.nsmax; trans_vordiv_to_UV(&vordiv_to_UV_g); fprintf(stderr,"Converting spectral vorticity-divergence to U-V globally...done\n"); #endif // Distribute spectral field (for fun) struct DistSpec_t distspec = new_distspec(&trans); distspec.rspec = rspscalar; distspec.rspecg = rspscalarg; distspec.nfld = nscalar; distspec.nfrom = nto; trans_distspec(&distspec); // Inverse Transform struct InvTrans_t invtrans = new_invtrans(&trans); invtrans.nscalar = nscalar; invtrans.nvordiv = nvordiv; invtrans.rspscalar = rspscalar; invtrans.rspvor = rspvor; invtrans.rspdiv = rspdiv; invtrans.rgp = rgp; trans_invtrans(&invtrans); if( trans.myproc == 1 ) { int i,j; for( j=0; j<3; ++j) { for( i=0; indgl = sizeof(T159)/sizeof(int); trans->nloen = malloc( sizeof(T159) ); for( i = 0; indgl; i++) trans->nloen[i] = T159[i]; // Assume Linear Grid trans->nsmax=(2*trans->ndgl-1)/2; } ectrans-1.8.0/tests/transi/transi_test_split_comm.c0000664000175000017500000000446015174631767022763 0ustar alastairalastair/* * (C) Crown Copyright 2025- Met Office. * * 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. */ #include #include #include #include "ectrans/transi.h" #include "transi_test.h" #include // ---------------------------------------------------------------------------- int getColour(const int world_rank) { return world_rank % 2; } // ---------------------------------------------------------------------------- int main ( int arc, char **argv ) { MPI_Init(&arc, &argv); trans_use_mpi(true); setbuf(stdout,NULL); // unbuffered stdout int world_size; MPI_Comm_size(MPI_COMM_WORLD, &world_size); int world_rank; MPI_Comm_rank(MPI_COMM_WORLD, &world_rank); // Split world communicator. const int colour = getColour(world_rank); MPI_Comm split_comm; MPI_Comm_split(MPI_COMM_WORLD, colour, world_rank, &split_comm); int split_size; MPI_Comm_size(split_comm, &split_size); // Set default fiat MPL comm. const MPI_Fint split_comm_int = MPI_Comm_c2f(split_comm); TRANS_CHECK( trans_set_mpi_comm(split_comm_int) ); // Initialise trans (+ MPL as a result) with split communicator. struct Trans_t trans; TRANS_CHECK( trans_new(&trans) ); const int nlon = 320; const int nlat = 161; const int nsmax = 159; TRANS_CHECK( trans_set_resol_lonlat(&trans,nlon,nlat) ); TRANS_CHECK( trans_set_trunc(&trans,nsmax) ); TRANS_CHECK( trans_setup(&trans) ); printf("World size => %d :: Split size => %d :: Trans size => %d\n", world_size, split_size, trans.nproc); ASSERT_MSG(world_size >= 2, "ERROR: Number of MPI processes for this test must be greater than or equal to 2."); ASSERT(trans.nproc == split_size); ASSERT(trans.nproc < world_size); ASSERT(trans.nproc <= world_size / 2); // Attempt to set up trans on WORLD - should fail, since MPL has already // been initialised on the split_comm const MPI_Fint world_comm_int = MPI_Comm_c2f(MPI_COMM_WORLD); const int ret_code = trans_set_mpi_comm(world_comm_int); ASSERT_MSG(ret_code != 0, "ERROR: Expected `trans_set_mpi_comm(MPI_COMM_WORLD)` " "to fail on second setup."); TRANS_CHECK( trans_finalize() ); MPI_Finalize(); return 0; } ectrans-1.8.0/tests/transi/transi_test.h0000664000175000017500000000354115174631767020541 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #ifndef TRANSI_TEST_H #define TRANSI_TEST_H #include #include #include "ectrans/transi.h" #define TRANS_CHECK( CALL ) do {\ int errcode = CALL;\ if( errcode != TRANS_SUCCESS) {\ printf("ERROR: %s failed @%s:%d:\n%s\n",#CALL,__FILE__,__LINE__,trans_error_msg(errcode));\ exit(1);\ }\ } while(0) #define TRANS_CHECK_ERROR( CALL, ERR ) do {\ int errcode = CALL;\ if( errcode != ERR ) {\ printf("ERROR: %s should fail with errcode %s(%d) @%s:%d:\n%s\n",#CALL,#ERR,ERR,__FILE__,__LINE__,trans_error_msg(errcode));\ exit(1);\ }\ } while(0) #define ASSERT( assertion ) do {\ if( !(assertion) ) {\ printf("ERROR: Assertion `%s' failed @%s:%d\n",#assertion,__FILE__,__LINE__);\ TRANS_CHECK( trans_delete(&trans) );\ exit(1);\ }\ } while(0) #define ASSERT_MSG( assertion, msg ) do {\ if( !(assertion) ) {\ printf("ERROR: Assertion `%s' failed @%s:%d => %s\n",#assertion,__FILE__,__LINE__,#msg);\ TRANS_CHECK( trans_delete(&trans) );\ exit(1);\ }\ } while(0) #define TRANS_ERROR -1 #define TRANS_NOTIMPL -2 #define TRANS_MISSING_ARG -3 #define TRANS_UNRECOGNIZED_ARG -4 #define TRANS_STALE_ARG -5 double transi_test_time(); void print_time(const char* str,double elapsed); void display_mallinfo(void); int allocated(); void print_mem(const char* str,const int bytes); void set_standard_rgg(struct Trans_t* trans, int N, int T); int test_use_mpi(); int transi_test_nprgpew(); #endif ectrans-1.8.0/tests/transi/transi_test_lam_invtrans_adjoint.c0000664000175000017500000001100515174631767025013 0ustar alastairalastair#include #include #include #include #include "ectrans/transi.h" #include "transi_test.h" // ---------------------------------------------------------------------------- double randomDouble() { uint64_t r53 = ((uint64_t)(rand()) << 21) ^ (rand() >> 2); return (double)r53 / 9007199254740991.0; // 2^53 - 1 } // ---------------------------------------------------------------------------- void test_lam_invtrans_adjoint() { double adjoint_tol = 1.e-6; printf("test_lam_invtrans_adjoint()\n"); struct Trans_t trans; TRANS_CHECK( trans_new(&trans) ); TRANS_CHECK( trans_set_resol_lam(&trans, 20, 18, 2500.0, 2500.0) ); TRANS_CHECK( trans_set_trunc_lam(&trans, 9, 8) ); TRANS_CHECK( trans_setup(&trans) ); TRANS_CHECK( trans_inquire(&trans,"nvalue,mvalue") ); // Number of fields int nscalar = 2; int nvordiv = 1; int nfld = 2*nvordiv+nscalar; // Allocate test data double* rgp1 = calloc( nfld * trans.ngptot, sizeof(double) ); double* rspvor1 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspdiv1 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspscalar1 = calloc( nscalar * trans.nspec2, sizeof(double) ); double* rmeanu1 = calloc( nvordiv, sizeof(double) ); double* rmeanv1 = calloc( nvordiv, sizeof(double) ); double* rgp2 = calloc( nfld * trans.ngptot, sizeof(double) ); double* rspvor2 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspdiv2 = calloc( nvordiv * trans.nspec2, sizeof(double) ); double* rspscalar2 = calloc( nscalar * trans.nspec2, sizeof(double) ); double* rmeanu2 = calloc( nvordiv, sizeof(double) ); double* rmeanv2 = calloc( nvordiv, sizeof(double) ); // Create random grid-point fields for(int j=0; j #include #include "ectrans/transi.h" #include "transi_test.h" // Following dummy functions are implementation details // that don't contribute to this example. They could be // replaced with grib_api functionality void read_rspec( struct Trans_t* trans, double* rspec[], int nfld ); int main ( int argc, char **argv ) { trans_use_mpi( test_use_mpi() ); double begin = transi_test_time(); struct Trans_t trans; trans_new(&trans); double start; int N = 80; int nfld = 10; printf( "Grid resolution: N = %d\n",N); printf( "Number of fields to transform: %d\n",nfld); printf( "\n" ); trans_init(); // Read resolution information set_standard_rgg(&trans,N,-1); // Register resolution in trans library start = transi_test_time(); trans_setup(&trans); if( trans.myproc == 1 ) printf( "trans_setup() ... "); if( trans.myproc == 1 ) print_time("",transi_test_time()-start); //for( nfld = 200; nfld<=250; ++nfld ) { double* rspec; read_rspec(&trans,&rspec,nfld); double* rgp = malloc( sizeof(double) * nfld*trans.ngptot ); // Inverse Transform struct InvTrans_t invtrans = new_invtrans(&trans); invtrans.nscalar = nfld; invtrans.rspscalar = rspec; invtrans.rgp = rgp; if( trans.myproc == 1 ) printf( "trans_invtrans(%3d) ... ",nfld); start = transi_test_time(); trans_invtrans(&invtrans); if( trans.myproc == 1 ) print_time("",transi_test_time()-start); free(rgp); free(rspec); } trans_delete(&trans); trans_finalize(); if( trans.myproc == 1 ) print_time("END transi_timings total: ",transi_test_time()-begin); return 0; } //--------------------------------------------------------------------------- // Dummy functions, used in this example void read_rspec(struct Trans_t* trans, double* rspec[], int nfld ) { int i,j; *rspec = malloc( sizeof(double) * nfld*trans->nspec2 ); for( i=0; inspec2; ++i ) { for( j=0; j/dev/null if [ $EXIT_CODE -ne 0 ]; then echo "+++++++++++++++++" echo "Test failed" echo "+++++++++++++++++" fi exit $EXIT_CODE } trap test_failed EXIT set -e -o pipefail set -x # Start with clean build rm -rf $BUILD if [ -z ${ectrans_ROOT+x} ]; then export ectrans_DIR=@PROJECT_BINARY_DIR@ else echo "ectrans_ROOT=$ectrans_ROOT" fi export ecbuild_DIR=@ecbuild_MACROS_DIR@/../lib/cmake/ecbuild # Build mkdir -p $BUILD && cd $BUILD cmake $SOURCE \ -DCMAKE_BUILD_TYPE=RelWithDebInfo \ -DECBUILD_2_COMPAT=OFF \ "$@" cmake --build . --verbose --parallel 1 # For some reason these compilers are more stack hungry if [[ "@CMAKE_Fortran_COMPILER_ID@" = "LLVMFlang" || \ "@CMAKE_Fortran_COMPILER_ID@" = "IntelLLVM" ]]; then ulimit -s unlimited fi if [ -f bin/main_dp ]; then bin/main_dp fi if [ -f bin/main_sp ]; then bin/main_sp fi if [ -f bin/transi_sptogp ]; then bin/transi_sptogp fi { set +ex; } 2>/dev/null echo "+++++++++++++++++" echo "Test passed" echo "+++++++++++++++++" ectrans-1.8.0/tests/CMakeLists.txt0000664000175000017500000004476715174631767017310 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. # -------------------------------------------------------------------------------------------------- # First establish which precisions and platforms to test # -------------------------------------------------------------------------------------------------- set( precisions "" ) if( HAVE_DOUBLE_PRECISION ) list( APPEND precisions "dp" ) endif() if( HAVE_SINGLE_PRECISION ) list( APPEND precisions "sp" ) endif() set( platforms ) if( HAVE_CPU ) list( APPEND platforms cpu ) endif() if( HAVE_GPU ) list( APPEND platforms gpu ) endif() # -------------------------------------------------------------------------------------------------- # Then set the MPI and OpenMP testing configurations # -------------------------------------------------------------------------------------------------- set( ntasks 0 ) if( HAVE_MPI ) list( APPEND ntasks 1 2 ) endif() set( nthreads 1 ) if( HAVE_OMP ) list( APPEND nthreads 8 ) endif() # -------------------------------------------------------------------------------------------------- # Add a test for installation of ecTrans # -------------------------------------------------------------------------------------------------- configure_file( test-install.sh.in ${CMAKE_CURRENT_BINARY_DIR}/test-install.sh @ONLY ) unset( _test_args ) if( CMAKE_TOOLCHAIN_FILE ) list( APPEND _test_args "-DCMAKE_TOOLCHAIN_FILE=${CMAKE_TOOLCHAIN_FILE}" ) endif() foreach( lang C CXX Fortran ) if( CMAKE_${lang}_COMPILER ) list( APPEND _test_args "-DCMAKE_${lang}_COMPILER=${CMAKE_${lang}_COMPILER}" ) endif() endforeach() foreach( lang C CXX Fortran ) if( CMAKE_${lang}_FLAGS ) list( APPEND _test_args "-DCMAKE_${lang}_FLAGS=${CMAKE_${lang}_FLAGS}" ) endif() endforeach() if( CMAKE_EXE_LINKER_FLAGS ) list( APPEND _test_args "-DCMAKE_EXE_LINKER_FLAGS=${CMAKE_EXE_LINKER_FLAGS}" ) endif() if( NOT HAVE_DOUBLE_PRECISION ) list( APPEND _test_args "-DCOMPONENTS=single" ) endif() add_test( NAME ectrans_test_install COMMAND ${CMAKE_CURRENT_BINARY_DIR}/test-install.sh ${_test_args} ) # -------------------------------------------------------------------------------------------------- # Add API tests # -------------------------------------------------------------------------------------------------- add_subdirectory( trans/api ) # -------------------------------------------------------------------------------------------------- # Add adjoint tests # -------------------------------------------------------------------------------------------------- add_subdirectory( trans/adjoint ) # -------------------------------------------------------------------------------------------------- # Add tests for common call patterns of ecTrans, using the benchmark program # This tests CPU and/or GPU versions, depending on which are enabled # -------------------------------------------------------------------------------------------------- macro(ectrans_set_test_properties target) if( "${target}" MATCHES "gpu" ) set_tests_properties(${target} PROPERTIES LABELS "gpu;Fortran") endif() set_tests_properties( ${target} PROPERTIES FIXTURES_SETUP checksum_tests ) endmacro() # Determine which benchmarks are available set( benchmarks "" ) if( TARGET ectrans-benchmark-cpu-dp ) list( APPEND benchmarks ectrans-benchmark-cpu-dp ) endif() if( TARGET ectrans-benchmark-cpu-sp ) list( APPEND benchmarks ectrans-benchmark-cpu-sp ) endif() if( TARGET ectrans-benchmark-gpu-dp ) list( APPEND benchmarks ectrans-benchmark-gpu-dp ) endif() if( TARGET ectrans-benchmark-gpu-sp ) list( APPEND benchmarks ectrans-benchmark-gpu-sp ) endif() foreach( benchmark ${benchmarks} ) # Establish which task/thread parameters to test set( ntasks 0 ) set( nthreads 1 ) if( HAVE_MPI ) list( APPEND ntasks 1 2 ) endif() if( ${benchmark} MATCHES "cpu" ) if( HAVE_OMP ) list( APPEND nthreads 8 ) endif() endif() if( NOT TEST compare_checksums AND (HAVE_MPI OR HAVE_OMP) ) configure_file( compare_checksums.py ${CMAKE_CURRENT_BINARY_DIR}/compare_checksums.py @ONLY ) list( JOIN ntasks "," ntasks_joined ) list( JOIN nthreads "," nthreads_joined ) ecbuild_add_test( TARGET compare_checksums COMMAND "${CMAKE_CURRENT_BINARY_DIR}/compare_checksums.py" ARGS "." ${ntasks_joined} ${nthreads_joined} ) set_tests_properties( compare_checksums PROPERTIES FIXTURES_REQUIRED checksum_tests ) endif() # Add test for each parameter combination foreach( mpi ${ntasks} ) foreach( omp ${nthreads} ) # TCO47 truncation set( t 47 ) set( grid O48 ) # Base arguments -> 2 iterations, memory consumption/pinning information, spectral norms, and # verbose output set( base_args --niter 2 --meminfo --norms -v ) foreach( callmode 1 2 ) set (base_title "${benchmark}_T${t}_${grid}_mpi${mpi}_omp${omp}_callmode${callmode}") # Check it works with 0 3D scalar fields ecbuild_add_test( TARGET ${base_title}_nfld0 COMMAND ${benchmark} ARGS --truncation ${t} --grid ${grid} --nfld 0 --check 100 --callmode ${callmode} --dump-checksums ${base_title}_nfld0 ${base_args} MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld0 ) # Check it works with 10 3D scalar fields and 20 levels ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20 COMMAND ${benchmark} ARGS --truncation ${t} --grid ${grid} --nfld 10 --nlev 20 --check 100 --callmode ${callmode} --dump-checksums ${base_title}_nfld10_nlev20 ${base_args} MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20 ) # Check it works with 10 3D scalar fields, 20 levels, and derivatives ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_derivatives COMMAND ${benchmark} ARGS --truncation ${t} --grid ${grid} --nfld 10 --nlev 20 --scders --uvders --check 100 --callmode ${callmode} --dump-checksums ${base_title}_nfld10_nlev20_derivatives ${base_args} MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_derivatives ) # Check it works with 10 3D scalar fields, 20 levels, and vordiv in grid point space ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_vordiv COMMAND ${benchmark} ARGS --truncation ${t} --grid ${grid} --nfld 10 --nlev 20 --vordiv --check 100 --callmode ${callmode} --dump-checksums ${base_title}_nfld10_nlev20_vordiv ${base_args} MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_vordiv ) # Check it works with 10 3D scalar fields, 20 levels, and NPROMA=16 ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_nproma16 COMMAND ${benchmark} ARGS --truncation ${t} --grid ${grid} --nfld 10 --nlev 20 --nproma 16 --check 100 --callmode ${callmode} --dump-checksums ${base_title}_nfld10_nlev20_nproma16 ${base_args} MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_nproma16 ) # Check it works with 10 3D scalar fields, 20 levels, and NPROMATR=20 (feature only works for CPU) if( ${benchmark} MATCHES "cpu" AND ${callmode} MATCHES "1" ) ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_npromatr20 COMMAND ${benchmark} ARGS --truncation ${t} --grid ${grid} --nfld 10 --nlev 20 --npromatr 20 --check 100 --callmode ${callmode} --dump-checksums ${base_title}_nfld10_nlev20_npromatr20 ${base_args} MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_npromatr20 ) endif() if( ${benchmark} MATCHES "cpu" ) # Check it works with 10 3D scalar fields, 20 levels, and the fast Legendre tranform (CPU only) # TODO: Find out why the FLT gives so much higher errors ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_flt COMMAND ${benchmark} ARGS --truncation ${t} --grid ${grid} --nfld 10 --nlev 20 --flt --check 1000000 --callmode ${callmode} --dump-checksums ${base_title}_nfld10_nlev20_flt ${base_args} MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_flt ) endif() endforeach() endforeach() endforeach() endforeach() # -------------------------------------------------------------------------------------------------- # Add tests for common call patterns of ecTrans LAM benchmark (i.e. etrans), using the benchmark # program # -------------------------------------------------------------------------------------------------- if( HAVE_ETRANS ) # Set resolution set( nlon 48 ) set( nlat 40 ) foreach( prec dp sp ) if( TARGET ectrans-lam-benchmark-cpu-${prec} ) set( nthreads 1 ) if( HAVE_OMP ) list( APPEND nthreads 8 ) endif() # Base arguments -> nlat x nlon, 2 iterations, memory consumption/pinning information, # spectral norms, and verbose output set( base_args --nlon ${nlon} --nlat ${nlat} --niter 2 --meminfo --norms -v ) foreach( mpi ${ntasks} ) foreach( omp ${nthreads} ) set(base_title "ectrans_lam_test_benchmark_${prec}_${nlon}x${nlat}_mpi${mpi}_omp${omp}" ) ecbuild_add_test( TARGET ${base_title}_nfld0 COMMAND ectrans-lam-benchmark-cpu-${prec} ARGS ${base_args} --nfld 0 --dump-checksums ${base_title}_nfld0 MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld0 ) ecbuild_add_test( TARGET ${base_title}_nfld10 COMMAND ectrans-lam-benchmark-cpu-${prec} ARGS ${base_args} --nfld 10 --dump-checksums ${base_title}_nfld10 MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10 ) ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20 COMMAND ectrans-lam-benchmark-cpu-${prec} ARGS ${base_args} --nfld 10 --nlev 20 --dump-checksums ${base_title}_nfld20 MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20 ) ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_scders COMMAND ectrans-lam-benchmark-cpu-${prec} ARGS ${base_args} --nfld 10 --nlev 20 --scders --dump-checksums ${base_title}_nfld10_nlev20_scders MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_scders ) ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_vordiv COMMAND ectrans-lam-benchmark-cpu-${prec} ARGS ${base_args} --nfld 10 --nlev 20 --vordiv --dump-checksums ${base_title}_nfld10_nlev20_vordiv MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_vordiv ) ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_vordiv_uvders COMMAND ectrans-lam-benchmark-cpu-${prec} ARGS ${base_args} --nfld 10 --nlev 20 --vordiv --uvders --dump-checksums ${base_title}_nfld10_nlev20_vordiv_uvders MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_vordiv_uvders ) ecbuild_add_test( TARGET ${base_title}_nfld10_nlev20_nproma16 COMMAND ectrans-lam-benchmark-cpu-${prec} ARGS ${base_args} --nfld 10 --nlev 20 --nproma 16 --dump-checksums ${base_title}_nfld10_nlev20_nproma16 MPI ${mpi} OMP ${omp} ) ectrans_set_test_properties( ${base_title}_nfld10_nlev20_nproma16 ) endforeach() endforeach() endif() endforeach() endif() # -------------------------------------------------------------------------------------------------- # Add test for split-communicator compatibility of ecTrans # -------------------------------------------------------------------------------------------------- # It doesn't really matter which precision we use for this test, as long as we use one that's # actually available if( HAVE_SINGLE_PRECISION ) set( trans_lib trans_sp ) set( parkind_lib parkind_sp ) else() set( trans_lib trans_dp ) set( parkind_lib parkind_dp ) endif() if( HAVE_CPU AND HAVE_MPI ) ecbuild_add_test(TARGET ectrans_test_split_mpi_comm SOURCES trans/test_split_mpi_comm.F90 LIBS ${trans_lib} ${parkind_lib} LINKER_LANGUAGE Fortran MPI 4 OMP 1 ) endif() # -------------------------------------------------------------------------------------------------- # Add tests for transi # -------------------------------------------------------------------------------------------------- if( HAVE_TRANSI ) check_include_files( malloc.h EC_HAVE_MALLOC_H ) ecbuild_debug_var( EC_HAVE_MALLOC_H ) if( EC_HAVE_MALLOC_H ) list( APPEND TEST_DEFINITIONS TRANSI_HAVE_MEMORY ) else() ecbuild_warn( "ectrans tests checking memory leaks are disabled as malloc.h was not found" ) endif() find_package( CMath ) ecbuild_add_library( TARGET ectrans_test SOURCES transi/transi_test.h transi/transi_test.c PUBLIC_LIBS transi_dp ${CMATH_LIBRARIES} NOINSTALL ) target_compile_definitions( ectrans_test PUBLIC ${TEST_DEFINITIONS} ) if( HAVE_GPU ) ecbuild_add_library( TARGET ectrans_test_gpu SOURCES transi/transi_test.h transi/transi_test.c PUBLIC_LIBS transi_gpu_dp NOINSTALL ) target_compile_definitions( ectrans_test PUBLIC ${TEST_DEFINITIONS} ) endif() ecbuild_add_test( TARGET ectrans_test_transi_program SOURCES transi/transi_test_program.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) if( HAVE_GPU ) ecbuild_add_test( TARGET ectrans_test_transi_program_gpu SOURCES transi/transi_test_program.c LIBS ectrans_test_gpu LINKER_LANGUAGE C DEFINITIONS GPU_VERSION ENVIRONMENT TRANS_USE_MPI=0 ) set_tests_properties(ectrans_test_transi_program_gpu PROPERTIES LABELS gpu) ecbuild_add_test( TARGET ectrans_test_transi_invtrans_adjoint_gpu SOURCES transi/transi_test_invtrans_adjoint.c LIBS ectrans_test_gpu LINKER_LANGUAGE C DEFINITIONS GPU_VERSION ENVIRONMENT TRANS_USE_MPI=0 ) set_tests_properties(ectrans_test_transi_invtrans_adjoint_gpu PROPERTIES LABELS gpu) ecbuild_add_test( TARGET ectrans_test_transi_dirtrans_adjoint_gpu SOURCES transi/transi_test_dirtrans_adjoint.c LIBS ectrans_test_gpu LINKER_LANGUAGE C DEFINITIONS GPU_VERSION ENVIRONMENT TRANS_USE_MPI=0 ) set_tests_properties(ectrans_test_transi_dirtrans_adjoint_gpu PROPERTIES LABELS gpu) endif() ecbuild_add_test( TARGET ectrans_test_transi_timings SOURCES transi/transi_test_timings.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_lonlat SOURCES transi/transi_test_lonlat.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_io SOURCES transi/transi_test_io.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_memory SOURCES transi/transi_test_memory.c LIBS ectrans_test CONDITION EC_HAVE_MALLOC_H LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_memory_lonlat SOURCES transi/transi_test_memory_lonlat.c LIBS ectrans_test CONDITION EC_HAVE_MALLOC_H LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_vordiv_to_UV SOURCES transi/transi_test_vordiv_to_UV.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_dirtrans_adjoint SOURCES transi/transi_test_dirtrans_adjoint.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_invtrans_adjoint SOURCES transi/transi_test_invtrans_adjoint.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_lonlat_diff_incr SOURCES transi/transi_test_lonlat_diff_incr.c LIBS ectrans_test LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_option( FEATURE MEMORY_TESTS DEFAULT ON DESCRIPTION "Enable memory tests" ) if( NOT HAVE_MEMORY_TESTS ) set_tests_properties( ectrans_test_transi_memory ectrans_test_transi_memory_lonlat PROPERTIES DISABLED ON ) endif() ecbuild_add_test( TARGET ectrans_test_transi_lam SOURCES transi/transi_test_lam.c LIBS ectrans_test LINKER_LANGUAGE C CONDITION HAVE_ETRANS ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_lam_dirtrans_adjoint SOURCES transi/transi_test_lam_dirtrans_adjoint.c LIBS ectrans_test LINKER_LANGUAGE C CONDITION HAVE_ETRANS ENVIRONMENT TRANS_USE_MPI=0 ) ecbuild_add_test( TARGET ectrans_test_transi_lam_invtrans_adjoint SOURCES transi/transi_test_lam_invtrans_adjoint.c LIBS ectrans_test LINKER_LANGUAGE C CONDITION HAVE_ETRANS ENVIRONMENT TRANS_USE_MPI=0 ) if( HAVE_MPI ) # Test ectrans_test_transi_split_comm requires MPI C find_package( MPI COMPONENTS C ) if ( MPI_C_FOUND ) ecbuild_add_test( TARGET ectrans_test_transi_split_comm SOURCES transi/transi_test_split_comm.c LIBS ectrans_test MPI::MPI_C MPI 2 LINKER_LANGUAGE C ENVIRONMENT TRANS_USE_MPI=1 ) endif() endif() if( HAVE_ETRANS_GPU ) ecbuild_add_test( TARGET ectrans_test_transi_lam_gpu SOURCES transi/transi_test_lam.c LIBS ectrans_test_gpu LINKER_LANGUAGE C DEFINITIONS GPU_VERSION CONDITION HAVE_ETRANS ENVIRONMENT TRANS_USE_MPI=0 ) if (TEST ectrans_test_transi_lam_gpu) set_tests_properties(ectrans_test_transi_lam_gpu PROPERTIES LABELS gpu) endif() endif() endif() ectrans-1.8.0/pyproject.toml0000664000175000017500000000120215174631767016273 0ustar alastairalastair[project] name = "ectrans4py" dynamic = ["version"] description = "ECTRANS interface for Python" readme = "README.md" requires-python = ">=3.10" dependencies=[ "numpy", "ctypesForFortran >=1.3.0, !=2.0.*, !=2.1.*", ] classifiers = [ 'Development Status :: 3 - Alpha', 'Intended Audience :: Science/Research', 'Programming Language :: Python', 'Programming Language :: Python :: 3.10', 'Programming Language :: Python :: 3.11', 'Programming Language :: Python :: 3.12', 'Operating System :: Unix', ] [build-system] requires = ["setuptools", "wheel", "scikit-build"] build-backend = "setuptools.build_meta" ectrans-1.8.0/src/0000775000175000017500000000000015174631767014153 5ustar alastairalastairectrans-1.8.0/src/etrans/0000775000175000017500000000000015174631767015447 5ustar alastairalastairectrans-1.8.0/src/etrans/common/0000775000175000017500000000000015174631767016737 5ustar alastairalastairectrans-1.8.0/src/etrans/common/internal/0000775000175000017500000000000015174631767020553 5ustar alastairalastairectrans-1.8.0/src/etrans/common/internal/esetup_geom_mod.F900000664000175000017500000000414215174631767024207 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESETUP_GEOM_MOD CONTAINS SUBROUTINE ESETUP_GEOM USE EC_PARKIND ,ONLY : JPIM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPMALD_DIM ,ONLY : RALD !USE TPM_FIELDS USE TPM_GEOMETRY ,ONLY : G ! IMPLICIT NONE INTEGER(KIND=JPIM) :: IDGLU(0:RALD%NMSMAX,R%NDGNH) INTEGER(KIND=JPIM) :: JGL,JM LOGICAL :: LLP1,LLP2 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESETUP_GEOM_MOD:ESETUP_GEOM',0,ZHOOK_HANDLE) IF(.NOT.D%LGRIDONLY) THEN LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SETUP_GEOM ===' ALLOCATE (G%NMEN(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'G%NMEN ',SIZE(G%NMEN ),SHAPE(G%NMEN ) G%NMEN(:)=RALD%NMSMAX IF(LLP1) THEN WRITE(NOUT,FMT='('' (JGL,G%NLOEN,G%NMEN) '')') WRITE(NOUT,FMT='(8(1X,''('',I4,I4,I4,'')''))')& & (JGL,G%NLOEN(JGL),G%NMEN(JGL),JGL=1,R%NDGL) ENDIF ALLOCATE(G%NDGLU(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'G%NDGLU ',SIZE(G%NDGLU ),SHAPE(G%NDGLU ) IDGLU(:,:) = 0 G%NDGLU(:) = 0 DO JGL=1,R%NDGNH DO JM=0,G%NMEN(JGL) IDGLU(JM,JGL) = 1 ENDDO ENDDO DO JM=0,RALD%NMSMAX DO JGL=1,R%NDGNH G%NDGLU(JM) = G%NDGLU(JM)+IDGLU(JM,JGL) ENDDO ENDDO IF(LLP1) THEN WRITE(NOUT,FMT='('' (JM,G%NDGLU) '')') WRITE(NOUT,FMT='(10(1X,''('',I4,I4,'')''))')& & (JM,G%NDGLU(JM),JM=0,RALD%NMSMAX) ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('ESETUP_GEOM_MOD:ESETUP_GEOM',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE ESETUP_GEOM END MODULE ESETUP_GEOM_MOD ectrans-1.8.0/src/etrans/common/internal/tpmald_dim.F900000664000175000017500000000222015174631767023141 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE TPMALD_DIM ! Module for dimensions. USE EC_PARKIND ,ONLY : JPIM, JPIB IMPLICIT NONE SAVE TYPE ALDDIM_TYPE ! COLLOCATION GRID DIMENSIONS INTEGER(KIND=JPIM) :: NDGLSUR ! Number of rows of latitudes+... INTEGER(KIND=JPIM) :: NMSMAX ! Zonal truncation INTEGER(KIND=JPIM) :: NDGUX ! Number of rows in zone C+I ! arguments to pass to EXECUTE_FFT: kept here to make sure their addresses are constant (necessary for cuda graphs) INTEGER(KIND=JPIM) :: NLOENS_LON(1) INTEGER(KIND=JPIB) :: NOFFSETS_LON(2) INTEGER(KIND=JPIM) :: NLOENS_LAT(1) INTEGER(KIND=JPIB) :: NOFFSETS_LAT(2) END TYPE ALDDIM_TYPE TYPE(ALDDIM_TYPE),ALLOCATABLE,TARGET :: ALDDIM_RESOL(:) TYPE(ALDDIM_TYPE),POINTER :: RALD END MODULE TPMALD_DIM ectrans-1.8.0/src/etrans/common/internal/ellips.F900000664000175000017500000000462515174631767022332 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! ! Jan-2011 P. Marguinaud Interface to thread-safe FA SUBROUTINE ELLIPS (KSMAX,KMSMAX,KNTMP,KMTMP) USE EC_PARKIND, ONLY : JPRD, JPIM USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE ! ! ***ELLIPS*** - General routine for computing elliptic truncation ! ! Purpose. ! -------- ! Computation of zonal and meridional limit wavenumbers within the ellipse ! Interface: ! ---------- ! *CALL* *ELLIPS * ! ! Explicit arguments : ! -------------------- ! ! Implicit arguments : ! -------------------- ! ! ! Method. ! ------- ! See documentation ! ! Externals. NONE. ! ---------- ! ! Reference. ! ---------- ! ARPEGE/ALADIN documentation ! ! Author. ! ------- ! G. Radnoti LACE 97/04/04 ! ! Modifications. ! !------------------------------------------------------------- ! J.Vivoda, 99/05/19 treating NSMAX=0 and NMSMAX=0 ! O.Nuissier, 23/09/01 Change type of real (simple --> ! double precision) ! ! INTEGER (KIND=JPIM) :: KSMAX, KMSMAX INTEGER (KIND=JPIM) :: KNTMP(0:KMSMAX),KMTMP(0:KSMAX) ! INTEGER (KIND=JPIM) :: JM, JN ! REAL (KIND=JPRD) :: ZEPS, ZKN, ZKM, ZAUXIL ! REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('ELLIPS',0,ZHOOK_HANDLE) ZEPS=1.E-10 ZAUXIL=0. ! ! 1. Computing meridional limit wavenumbers along zonal wavenumbers ! DO JM=1,KMSMAX-1 ZKN = REAL(KSMAX,JPRD)/REAL(KMSMAX,JPRD)* & & SQRT(MAX(ZAUXIL,REAL(KMSMAX**2-JM**2,JPRD))) KNTMP(JM)=INT(ZKN+ZEPS, JPIM) ENDDO IF( KMSMAX == 0 )THEN KNTMP(0)=KSMAX ELSE KNTMP(0)=KSMAX KNTMP(KMSMAX)=0 ENDIF ! ! 2. Computing zonal limit wavenumbers along meridional wavenumbers ! DO JN=1,KSMAX-1 ZKM = REAL(KMSMAX,JPRD)/REAL(KSMAX,JPRD)* & & SQRT(MAX(ZAUXIL,REAL(KSMAX**2-JN**2,JPRD))) KMTMP(JN)=INT(ZKM+ZEPS, JPIM) ENDDO IF( KSMAX == 0 )THEN KMTMP(0)=KMSMAX ELSE KMTMP(0)=KMSMAX KMTMP(KSMAX)=0 ENDIF ! IF (LHOOK) CALL DR_HOOK('ELLIPS',1,ZHOOK_HANDLE) END SUBROUTINE ELLIPS ectrans-1.8.0/src/etrans/common/internal/esetup_dims_mod.F900000664000175000017500000000277615174631767024227 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESETUP_DIMS_MOD CONTAINS SUBROUTINE ESETUP_DIMS USE EC_PARKIND ,ONLY : JPIM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD ! IMPLICIT NONE INTEGER(KIND=JPIM) :: JM,JN,ISPOLEG INTEGER(KIND=JPIM) :: ISMAX(0:R%NSMAX),ISNAX(0:RALD%NMSMAX) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESETUP_DIMS_MOD:ESETUP_DIMS',0,ZHOOK_HANDLE) ISPOLEG = 0 DO JM=0,R%NSMAX DO JN=JM,R%NTMAX+1 ISPOLEG = ISPOLEG+1 ENDDO ENDDO R%NSPOLEG = ISPOLEG CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) R%NSPEC_G=0 DO JM=0,RALD%NMSMAX R%NSPEC_G=R%NSPEC_G+2*(ISNAX(JM)+1) ENDDO R%NSPEC2_G = R%NSPEC_G*2 R%NDGNH = (R%NDGL+1)/2 R%NLEI1 = R%NSMAX+4+MOD(R%NSMAX+4+1,2) R%NLEI3 = R%NDGNH+MOD(R%NDGNH+2,2) R%NLED3 = R%NTMAX+2+MOD(R%NTMAX+3,2) R%NLED4 = R%NTMAX+3+MOD(R%NTMAX+4,2) IF (LHOOK) CALL DR_HOOK('ESETUP_DIMS_MOD:ESETUP_DIMS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESETUP_DIMS END MODULE ESETUP_DIMS_MOD ectrans-1.8.0/src/etrans/common/internal/suemplat_mod.F900000664000175000017500000002157415174631767023535 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE SUEMPLAT_MOD CONTAINS SUBROUTINE SUEMPLAT(KDGL,KPROC,KPROCA,KMYSETA,LDSPLIT,LDEQ_REGIONS,& & KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& & KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,& & PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& & KMEDIAP,KRESTM,LDSPLITLAT,KMYPROC,KLOEN,KDGUX) !**** *SUEMPLAT * - Initialize gridpoint distrbution in N-S direction ! Purpose. ! -------- !** Interface. ! ---------- ! *CALL* *SUEMPLAT * ! Explicit arguments - input : ! -------------------- ! KDGL -last latitude ! KPROC -total number of processors ! KPROCA -number of processors in A direction ! KMYSETA -process number in A direction ! LDSPLIT -true for latitudes shared between sets ! PWEIGHT -weight per grid-point if weighted ! distribution ! LDEQ_REGIONS -true if eq_regions partitioning ! LDWEIGHTED_DISTR -true if weighted distribution ! Explicit arguments - output: ! -------------------- ! KMEDIAP -mean number of grid points per PE ! KRESTM -number of PEs with one extra point ! KFRSTLAT -first latitude row on processor ! KLSTLAT -last latitude row on processor ! KFRSTLOFF -offset for first latitude in set ! KPROCAGP -number of grid points per A set ! KPTRLAT -pointer to start of latitude ! KPTRFRSTLAT-pointer to first latitude ! KPTRLSTLAT -pointer to last latitude ! KPTRFLOFF -offset for pointer to first latitude ! LDSPLITLAT -true for latitudes which are split ! PMEDIAP -mean weight per PE if weighted ! distribution ! ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. SUMPLATB and SUEMPLATB. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! David Dent:97-06-02 parameters KFRSTLAT etc added ! JF. Estrade:97-11-13 Adaptation to ALADIN case ! J.Boutahar: 98-07-06 phasing with CY19 ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option + cleanings ! (correct computation of extrapolar latitudes for KPROCL). ! Modified 98-12-07 by K. YESSAD and C. FISCHER: cleaning. ! - merge old sumplat.F and suemplat.F ! - gather 'lelam' code and 'not lelam' code. ! - clean (useless duplication of variables, non doctor features). ! - remodularise according to lelam/not lelam ! -> lelam features in new routine suemplatb.F, ! not lelam features in new routine sumplatb.F ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Bogatchev 20-Sep-2010 Phasing cy37 ! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM ,JPRD USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE SUEMPLATB_MOD ,ONLY : SUEMPLATB USE SUMPLATBEQ_MOD ,ONLY : SUMPLATBEQ USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE ! * DUMMY: INTEGER(KIND=JPIM),INTENT(OUT) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(OUT) :: KRESTM INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KPROC INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA INTEGER(KIND=JPIM),INTENT(IN) :: KMYSETA INTEGER(KIND=JPIM),INTENT(OUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KLSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KFRSTLOFF INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRFLOFF INTEGER(KIND=JPIM),INTENT(OUT) :: KPROCAGP(KPROCA) REAL(KIND=JPRD),INTENT(OUT) :: PMEDIAP REAL(KIND=JPRD),INTENT(IN) :: PWEIGHT(:) LOGICAL,INTENT(IN) :: LDSPLIT LOGICAL,INTENT(IN) :: LDEQ_REGIONS LOGICAL,INTENT(OUT) :: LDSPLITLAT(:) LOGICAL,INTENT(INOUT) :: LDWEIGHTED_DISTR INTEGER(KIND=JPIM),INTENT(IN) :: KMYPROC INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(KDGL) INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX ! === END OF INTERFACE BLOCK === INTEGER(KIND=JPIM) :: INDIC(KPROCA),ILAST(KPROCA) INTEGER(KIND=JPIM) :: IPTRLATITUDE, JA, JGL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE LOGICAL :: LLFOURIER LOGICAL, PARAMETER :: LLDEBUG=.FALSE. ! ----------------------------------------------------------------- !* 1. CODE DEPENDING ON 'LELAM': COMPUTATION OF ! KMEDIAP, KRESTM, INDIC, ILAST. ! ----------------------------------------- IF (LHOOK) CALL DR_HOOK('SUEMPLAT_MOD:SUEMPLAT',0,ZHOOK_HANDLE) INDIC(:)=0 ILAST(:)=0 IF(LDWEIGHTED_DISTR.AND..NOT.LDEQ_REGIONS)THEN CALL ABORT_TRANS ('SUEMPLAT: LDWEIGHTED_DISTR=T AND LDEQ_REGIONS=F NOT SUPPORTED') ENDIF IF( LDEQ_REGIONS )THEN CALL SUMPLATBEQ(1,KDGL,KPROC,KPROCA,KLOEN,LDSPLIT,LDEQ_REGIONS,& &PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& &KMEDIAP,KRESTM,INDIC,ILAST) ELSE LLFOURIER=.FALSE. !REK commented out for now ... monkey business to be done again, should lead to the use of sumplatb !REK CALL SUMPLATB(1,KDGL,KPROCA,G%NLOEN,LDSPLIT,LLFOURIER,& !REK &KMEDIAP,KRESTM,INDIC,ILAST) CALL SUEMPLATB(1,KDGL,KPROCA,KLOEN,LDSPLIT,& & PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& & KMEDIAP,KRESTM,INDIC,ILAST,KDGUX) ENDIF ! ----------------------------------------------------------------- !* 2. CODE NOT DEPENDING ON 'LELAM': COMPUTATION OF ! KFRSTLAT TO LDSPLITLAT. ! --------------------------------------------- ! * Computation of first and last latitude of processor sets ! ----------- in grid-point-space ----------------------- IF(KMYPROC==1.AND.LLDEBUG)THEN WRITE(0,'("")') WRITE(0,'("SUEMPLAT_MOD:LDWEIGHTED_DISTR=",L1)')LDWEIGHTED_DISTR WRITE(0,'("")') DO JA=1,KPROCA WRITE(0,'("SUEMPLAT_MOD: JA=",I3," ILAST=",I3," INDIC=",I3)')& &JA,ILAST(JA),INDIC(JA) ENDDO WRITE(0,'("")') IF( LDEQ_REGIONS .AND. LDSPLIT )THEN DO JA=1,KPROCA WRITE(0,'("SUEMPLAT_MOD: JA=",I3," KPROCAGP=",I8)')& &JA,KPROCAGP(JA) ENDDO WRITE(0,'("")') ENDIF ENDIF KFRSTLAT(1) = 1 KLSTLAT(KPROCA) = KDGL DO JA=1,KPROCA-1 IF(KMYPROC==1 .AND. NPRINTLEV > 1)THEN WRITE(NOUT,'("SUEMPLAT_MOD: JA=",I3," ILAST=",I3," INDIC=",I3)')& &JA,ILAST(JA),INDIC(JA) ENDIF IF ((.NOT. LDSPLIT) .OR. INDIC(JA) == 0) THEN KFRSTLAT(JA+1) = ILAST(JA) + 1 KLSTLAT(JA) = ILAST(JA) ELSE KFRSTLAT(JA+1) = INDIC(JA) KLSTLAT(JA) = INDIC(JA) ENDIF ENDDO KFRSTLOFF=KFRSTLAT(KMYSETA)-1 ! * Initialise following data structures:- ! NPTRLAT (pointer to the start of each latitude) ! LSPLITLAT (TRUE if latitude is split over two A sets) ! NPTRFRSTLAT (pointer to the first latitude of each A set) ! NPTRLSTLAT (pointer to the last latitude of each A set) DO JGL=1,KDGL KPTRLAT (JGL)=-999 LDSPLITLAT(JGL)=.FALSE. ENDDO IPTRLATITUDE=0 DO JA=1,KPROCA DO JGL=KFRSTLAT(JA),KLSTLAT(JA) IPTRLATITUDE=IPTRLATITUDE+1 LDSPLITLAT(JGL)=.TRUE. IF( KPTRLAT(JGL) == -999 )THEN KPTRLAT(JGL)=IPTRLATITUDE LDSPLITLAT(JGL)=.FALSE. ENDIF ENDDO ENDDO DO JA=1,KPROCA IF( LDSPLITLAT(KFRSTLAT(JA)) .AND. JA /= 1 )THEN KPTRFRSTLAT(JA)=KPTRLAT(KFRSTLAT(JA))+1 ELSE KPTRFRSTLAT(JA)=KPTRLAT(KFRSTLAT(JA)) ENDIF IF( LDSPLITLAT(KLSTLAT(JA)) .AND. JA == KPROCA)THEN KPTRLSTLAT(JA)=KPTRLAT(KLSTLAT(JA))+1 ELSE KPTRLSTLAT(JA)=KPTRLAT(KLSTLAT(JA)) ENDIF ENDDO KPTRFLOFF=KPTRFRSTLAT(KMYSETA)-1 IF(KMYPROC==1 .AND. NPRINTLEV > 1)THEN DO JGL=1,KDGL WRITE(NOUT,'("SUEMPLAT_MOD: JGL=",I3," KPTRLAT=",I3," LDSPLITLAT=",L4)')& & JGL,KPTRLAT(JGL),LDSPLITLAT(JGL) ENDDO DO JA=1,KPROCA WRITE(NOUT,'("SUEMPLAT_MOD: JA=",I3," KFRSTLAT=",I3," KLSTLAT=",I3,& & " KPTRFRSTLAT=",I3," KPTRLSTLAT=",I3)')& & JA,KFRSTLAT(JA),KLSTLAT(JA),KPTRFRSTLAT(JA),KPTRLSTLAT(JA) ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('SUEMPLAT_MOD:SUEMPLAT',1,ZHOOK_HANDLE) END SUBROUTINE SUEMPLAT END MODULE SUEMPLAT_MOD ectrans-1.8.0/src/etrans/common/internal/tpmald_distr.F900000664000175000017500000000172115174631767023522 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE TPMALD_DISTR ! Module for distributed memory environment. USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE SAVE TYPE ALDDISTR_TYPE INTEGER(KIND=JPIM) ,POINTER :: NESM0(:) ! Address in a spectral array of (m, n=m) INTEGER(KIND=JPIM) ,POINTER :: NCPL2M(:) ! Number of complex Laplace coefficient for m given INTEGER(KIND=JPIM) ,POINTER :: NPME(:) ! Address for the Laplace operator and its inverse END TYPE ALDDISTR_TYPE TYPE(ALDDISTR_TYPE),ALLOCATABLE,TARGET :: ALDDISTR_RESOL(:) TYPE(ALDDISTR_TYPE),POINTER :: DALD END MODULE TPMALD_DISTR ectrans-1.8.0/src/etrans/common/internal/suemplatb_mod.F900000664000175000017500000001651115174631767023672 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE SUEMPLATB_MOD CONTAINS SUBROUTINE SUEMPLATB(KDGSA,KDGL,KPROCA,KLOENG,LDSPLIT,& & PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& & KMEDIAP,KRESTM,KINDIC,KLAST,KDGUX) !**** *SUMPLATB * - Routine to initialize parallel environment ! Purpose. ! -------- !** Interface. ! ---------- ! *CALL* *SUMPLATB * ! Explicit arguments - input : ! -------------------- ! KDGSA -first latitude (grid-space) ! (may be different from NDGSAG) ! KDGL -last latitude ! KPROCA -number of processors in A direction ! KLOENG -actual number of longitudes per latitude. ! LDSPLIT -true for latitudes shared between sets ! KDGUX -last latitude for meaningful computations ! (suggested to pass NDGUX in gp-space, NDGL in Fourier space ! for having a good load-balance) ! PWEIGHT -weight per grid-point if weighted distribution ! LDWEIGHTED_DISTR -true if weighted distribution` ! Explicit arguments - output: ! -------------------- ! KMEDIAP -mean number of grid points per PE ! KPROCAGP -number of grid points per A set ! KRESTM -number of PEs with one extra point ! KINDIC -intermediate quantity for 'sumplat' ! KLAST -intermediate quantity for 'sumplat' ! PMEDIAP -mean weight per PE if weighted distribution ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. NONE. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! K. YESSAD (after old version of sumplat.F). ! Modifications. ! -------------- ! Original : 98-12-07 ! G. Radnoti: 03-03-03: Semi-merge with sumplatb, only difference: ! NS-partitioning according to NDGUX ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Bogatchev 21-Sep-2010 phasing CY37 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM, JPRD USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE ! * DUMMY: INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA INTEGER(KIND=JPIM),INTENT(IN) :: KLOENG(KDGSA:KDGL) REAL(KIND=JPRD),INTENT(IN) :: PWEIGHT(:) LOGICAL,INTENT(IN) :: LDSPLIT LOGICAL,INTENT(INOUT) :: LDWEIGHTED_DISTR INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(OUT) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(OUT) :: KRESTM INTEGER(KIND=JPIM),INTENT(OUT) :: KINDIC(KPROCA) INTEGER(KIND=JPIM),INTENT(OUT) :: KLAST(KPROCA) INTEGER(KIND=JPIM),INTENT(IN) :: KPROCAGP(KPROCA) REAL(KIND=JPRD),INTENT(IN) :: PMEDIAP INTEGER(KIND=JPIM) :: IPP1(KPROCA),ILAST1(KPROCA) INTEGER(KIND=JPIM) :: IPP(KPROCA) INTEGER(KIND=JPIM) :: IFIRST(KPROCA) INTEGER(KIND=JPIM) :: ICOMP, IGL, IMAXI, IMAXIOL, IMEDIA, ITOT, JA, JGL,& & ILAST,IREST,ILIMIT,IFRST LOGICAL :: LLDONE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ----------------------------------------------------------------- !* 1. COMPUTATION OF KMEDIAP, KRESTM, KINDIC, KLAST. ! ---------------------------------------------- ! * Computation of KMEDIAP and KRESTM. IF (LHOOK) CALL DR_HOOK('SUEMPLATB_MOD:SUEMPLATB',0,ZHOOK_HANDLE) IF (LDWEIGHTED_DISTR) THEN CALL ABORT_TRANS ('SUMPLATBEQ: ALADIN CODE IS NOT PREPARED FOR WEIGHTED DISTRIBUTION') ENDIF IMEDIA = SUM(KLOENG(KDGSA:KDGUX)) KMEDIAP = IMEDIA / KPROCA IF (KMEDIAP < KLOENG(KDGL/2)) THEN CALL ABORT_TRANS ('SUMPLATB: KPROCA TOO BIG FOR THIS RESOLUTION') ENDIF KRESTM = IMEDIA - KMEDIAP * KPROCA IF (KRESTM > 0) KMEDIAP = KMEDIAP + 1 ! * Computation of intermediate quantities KINDIC and KLAST IF (LDSPLIT) THEN IREST = 0 ILAST =0 DO JA=1,KPROCA IF (JA <= KRESTM .OR. KRESTM == 0) THEN ICOMP = KMEDIAP ELSE ICOMP = KMEDIAP - 1 ENDIF ITOT = IREST IGL = ILAST+1 DO JGL=IGL,KDGUX ILAST = JGL IF(ITOT+KLOENG(JGL) < ICOMP) THEN ITOT = ITOT+KLOENG(JGL) ELSEIF(ITOT+KLOENG(JGL) == ICOMP) THEN IREST = 0 KLAST(JA) = JGL KINDIC(JA) = 0 EXIT ELSE IREST = KLOENG(JGL) -(ICOMP-ITOT) KLAST(JA) = JGL KINDIC(JA) = JGL EXIT ENDIF ENDDO ENDDO KLAST(KPROCA)=KDGL KINDIC(KPROCA)=0 ELSE KINDIC(:) = 0 IMAXI = KMEDIAP-1 IMAXIOL = HUGE(IMAXIOL) DO ILIMIT = IMAXI IMAXI = 0 IFRST = KDGUX ILAST1(:) = 0 IPP1(:) = 0 DO JA=KPROCA,1,-1 IGL = IFRST LATS:DO JGL=IGL,1,-1 IF (IPP1(JA) < ILIMIT .OR. JA == 1) THEN IFRST = JGL-1 IPP1(JA) = IPP1(JA) + KLOENG(JGL) IF(ILAST1(JA) == 0) ILAST1(JA) = JGL ELSE EXIT LATS ENDIF ENDDO LATS IMAXI = MAX (IMAXI,IPP1(JA)) ENDDO IF(IMAXI >= IMAXIOL) EXIT KLAST(:) = ILAST1(:) IPP(:) = IPP1(:) IMAXIOL = IMAXI ENDDO ! make the distribution more uniform ! ---------------------------------- IFIRST(1) = 0 IF (KLAST(1) > 0) IFIRST(1) = 1 DO JA=2,KPROCA IF (IPP(JA) > 0) THEN IFIRST(JA) = KLAST(JA-1)+1 ELSE IFIRST(JA) = 0 ENDIF ENDDO LLDONE = .FALSE. DO WHILE( .NOT.LLDONE ) LLDONE = .TRUE. DO JA=1,KPROCA-1 IF (IPP(JA) > IPP(JA+1)) THEN IF (IPP(JA)-IPP(JA+1) > IPP(JA+1) + 2 *& & KLOENG(KLAST(JA)) -IPP(JA) ) THEN IPP(JA) = IPP(JA) - KLOENG(KLAST(JA)) IPP(JA+1) = IPP(JA+1) + KLOENG(KLAST(JA)) IF (KLAST(JA+1) == 0) KLAST(JA+1) = KLAST(JA) IFIRST(JA+1) = KLAST(JA) KLAST(JA) = KLAST(JA) - 1 IF (KLAST(JA) == 0) IFIRST(JA) = 0 LLDONE = .FALSE. ENDIF ELSE IF( IFIRST(JA+1) > 0 )THEN IF (IPP(JA+1)-IPP(JA) >= IPP(JA) + 2 *& & KLOENG(IFIRST(JA+1)) -IPP(JA+1) ) THEN IPP(JA) = IPP(JA) + KLOENG(IFIRST(JA+1)) IPP(JA+1) = IPP(JA+1) - KLOENG(IFIRST(JA+1)) KLAST(JA) = IFIRST(JA+1) IF (IFIRST(JA) == 0) IFIRST(JA) = KLAST(JA) IF (KLAST(JA+1) == KLAST(JA)) THEN KLAST(JA+1) = 0 IFIRST(JA+1) = 0 ELSE IFIRST(JA+1) = IFIRST(JA+1) + 1 ENDIF LLDONE = .FALSE. ENDIF ENDIF ENDIF ENDDO ENDDO KLAST(KPROCA)=KDGL ENDIF IF (LHOOK) CALL DR_HOOK('SUEMPLATB_MOD:SUEMPLATB',1,ZHOOK_HANDLE) END SUBROUTINE SUEMPLATB END MODULE SUEMPLATB_MOD ectrans-1.8.0/src/etrans/common/CMakeLists.txt0000664000175000017500000000317115174631767021501 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. ## Sources which are precision independent can go into a common library list( APPEND ectrans_lam_common_src internal/tpmald_distr.F90 internal/tpmald_dim.F90 internal/esetup_dims_mod.F90 internal/esetup_geom_mod.F90 internal/suemplat_mod.F90 internal/suemplatb_mod.F90 internal/ellips.F90 ) list( APPEND ectrans_lam_common_includes ) ecbuild_add_library( TARGET ectrans_lam_common LINKER_LANGUAGE Fortran SOURCES ${ectrans_lam_common_src} PUBLIC_LIBS fiat ectrans_common PRIVATE_LIBS ${LAPACK_LIBRARIES} PUBLIC_INCLUDES $ $ $ $ ) ecbuild_target_fortran_module_directory( TARGET ectrans_lam_common MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/ectrans INSTALL_MODULE_DIRECTORY module/ectrans ) if( HAVE_OMP ) ecbuild_debug("target_link_libraries( ectrans_common PRIVATE OpenMP::OpenMP_Fortran )") target_link_libraries( ectrans_lam_common PRIVATE OpenMP::OpenMP_Fortran ) endif() set( ectrans_lam_common_includes ${ectrans_lam_common_includes} PARENT_SCOPE ) ectrans-1.8.0/src/etrans/sedrenames.txt0000664000175000017500000001507015174631767020341 0ustar alastairalastairs/CPL_INT/CPL_INT_VARIANTDESIGNATOR/g s/EASRE1AD_MOD/EASRE1AD_MOD_VARIANTDESIGNATOR/g s/EASRE1B_MOD/EASRE1B_MOD_VARIANTDESIGNATOR/g s/EASRE1BAD_MOD/EASRE1BAD_MOD_VARIANTDESIGNATOR/g s/EDEALLOC_RESOL_MOD/EDEALLOC_RESOL_MOD_VARIANTDESIGNATOR/g s/EDIR_TRANS_CTL_MOD/EDIR_TRANS_CTL_MOD_VARIANTDESIGNATOR/g s/EDIR_TRANS_CTLAD_MOD/EDIR_TRANS_CTLAD_MOD_VARIANTDESIGNATOR/g s/edir_trans( *($|\(| |\*))/edir_trans_VARIANTDESIGNATOR\1/g s/EDIR_TRANS( *($|\(| |\*))/EDIR_TRANS_VARIANTDESIGNATOR\1/g s/edir_transad( *($|\(| |\*))/edir_transad_VARIANTDESIGNATOR\1/g s/EDIR_TRANSAD( *($|\(| |\*))/EDIR_TRANSAD_VARIANTDESIGNATOR\1/g s/DIST_GRID_CTL_MOD/DIST_GRID_CTL_MOD_VARIANTDESIGNATOR/g s/edist_grid( *($|\(| |\*))/edist_grid_VARIANTDESIGNATOR\1/g s/EDIST_GRID( *($|\(| |\*))/EDIST_GRID_VARIANTDESIGNATOR\1/g s/DIST_SPEC_CONTROL_MOD/DIST_SPEC_CONTROL_MOD_VARIANTDESIGNATOR/g s/edist_spec( *($|\(| |\*))/edist_spec_VARIANTDESIGNATOR\1/g s/EDIST_SPEC( *($|\(| |\*))/EDIST_SPEC_VARIANTDESIGNATOR\1/g s/FOURIER_IN_MOD/FOURIER_IN_MOD_VARIANTDESIGNATOR/g s/FOURIER_INAD_MOD/FOURIER_INAD_MOD_VARIANTDESIGNATOR/g s/FOURIER_OUT_MOD/FOURIER_OUT_MOD_VARIANTDESIGNATOR/g s/FOURIER_OUTAD_MOD/FOURIER_OUTAD_MOD_VARIANTDESIGNATOR/g s/FSPGL_INT_MOD/FSPGL_INT_MOD_VARIANTDESIGNATOR/g s/EFSC_MOD/EFSC_MOD_VARIANTDESIGNATOR/g s/EFSCAD_MOD/EFSCAD_MOD_VARIANTDESIGNATOR/g s/EFTDIR_CTL_MOD/EFTDIR_CTL_MOD_VARIANTDESIGNATOR/g s/EFTDIR_CTLAD_MOD/EFTDIR_CTLAD_MOD_VARIANTDESIGNATOR/g s/FTDIR_MOD/FTDIR_MOD_VARIANTDESIGNATOR/g s/FTDIRAD_MOD/FTDIRAD_MOD_VARIANTDESIGNATOR/g s/EFTINV_CTL_MOD/EFTINV_CTL_MOD_VARIANTDESIGNATOR/g s/EFTINV_CTLAD_MOD/EFTINV_CTLAD_MOD_VARIANTDESIGNATOR/g s/FTINV_MOD/FTINV_MOD_VARIANTDESIGNATOR/g s/FTINVAD_MOD/FTINVAD_MOD_VARIANTDESIGNATOR/g s/fpbipere( *($|\(| |\*))/fpbipere_VARIANTDESIGNATOR\1/g s/FPBIPERE( *($|\(| |\*))/FPBIPERE_VARIANTDESIGNATOR\1/g s/GATH_GRID_CTL_MOD/GATH_GRID_CTL_MOD_VARIANTDESIGNATOR/g s/egath_grid( *($|\(| |\*))/egath_grid_VARIANTDESIGNATOR\1/g s/EGATH_GRID( *($|\(| |\*))/EGATH_GRID_VARIANTDESIGNATOR\1/g s/GATH_SPEC_CONTROL_MOD/GATH_SPEC_CONTROL_MOD_VARIANTDESIGNATOR/g s/EGATH_SPEC_CONTROL_MOD/EGATH_SPEC_CONTROL_MOD_VARIANTDESIGNATOR/g s/egath_spec( *($|\(| |\*))/egath_spec_VARIANTDESIGNATOR\1/g s/EGATH_SPEC( *($|\(| |\*))/EGATH_SPEC_VARIANTDESIGNATOR\1/g s/GPNORM_TRANS_CTL_MOD/GPNORM_TRANS_CTL_MOD_VARIANTDESIGNATOR/g s/egpnorm_trans( *($|\(| |\*))/egpnorm_trans_VARIANTDESIGNATOR\1/g s/EGPNORM_TRANS( *($|\(| |\*))/EGPNORM_TRANS_VARIANTDESIGNATOR\1/g s/gpnorm_trans( *($|\(| |\*))/gpnorm_trans_VARIANTDESIGNATOR\1/g s/GPNORM_TRANS( *($|\(| |\*))/GPNORM_TRANS_VARIANTDESIGNATOR\1/g s/EINV_TRANS_CTL_MOD/EINV_TRANS_CTL_MOD_VARIANTDESIGNATOR/g s/EINV_TRANS_CTLAD_MOD/EINV_TRANS_CTLAD_MOD_VARIANTDESIGNATOR/g s/einv_trans( *($|\(| |\*))/einv_trans_VARIANTDESIGNATOR\1/g s/EINV_TRANS( *($|\(| |\*))/EINV_TRANS_VARIANTDESIGNATOR\1/g s/einv_transad( *($|\(| |\*))/einv_transad_VARIANTDESIGNATOR\1/g s/EINV_TRANSAD/EINV_TRANSAD_VARIANTDESIGNATOR/g s/jprbt/TYPEDESIGNATOR_LOWER/g s/JPRBT/TYPEDESIGNATOR_UPPER/g s/jprb/TYPEDESIGNATOR_LOWER/g s/JPRB/TYPEDESIGNATOR_UPPER/g s/JPRH/JPRD/g s/ELEDIR_MOD/ELEDIR_MOD_VARIANTDESIGNATOR/g s/ELEDIRAD_MOD/ELEDIRAD_MOD_VARIANTDESIGNATOR/g s/ELEINV_MOD/ELEINV_MOD_VARIANTDESIGNATOR/g s/ELEINVAD_MOD/ELEINVAD_MOD_VARIANTDESIGNATOR/g s/ELTDIR_CTL_MOD/ELTDIR_CTL_MOD_VARIANTDESIGNATOR/g s/ELTDIR_CTLAD_MOD/ELTDIR_CTLAD_MOD_VARIANTDESIGNATOR/g s/ELTDIR_MOD/ELTDIR_MOD_VARIANTDESIGNATOR/g s/ELTDIRAD_MOD/ELTDIRAD_MOD_VARIANTDESIGNATOR/g s/ELTINV_CTL_MOD/ELTINV_CTL_MOD_VARIANTDESIGNATOR/g s/ELTINV_CTLAD_MOD/ELTINV_CTLAD_MOD_VARIANTDESIGNATOR/g s/ELTINV_MOD/ELTINV_MOD_VARIANTDESIGNATOR/g s/ELTINVAD_MOD/ELTINVAD_MOD_VARIANTDESIGNATOR/g s/parkind1/ec_parkind/g s/PARKIND1/EC_PARKIND/g s/PARKIND2/EC_PARKIND/g s/parkind_ectrans/ec_parkind/g s/PARKIND_ECTRANS/ec_parkind/g s/EPRFI1_MOD/EPRFI1_MOD_VARIANTDESIGNATOR/g s/EPRFI1AD_MOD/EPRFI1AD_MOD_VARIANTDESIGNATOR/g s/EPRFI1B_MOD/EPRFI1B_MOD_VARIANTDESIGNATOR/g s/EPRFI1BAD_MOD/EPRFI1BAD_MOD_VARIANTDESIGNATOR/g s/EPRFI2_MOD/EPRFI2_MOD_VARIANTDESIGNATOR/g s/EPRFI2AD_MOD/EPRFI2AD_MOD_VARIANTDESIGNATOR/g s/EPRFI2B_MOD/EPRFI2B_MOD_VARIANTDESIGNATOR/g s/EPRFI2BAD_MOD/EPRFI2BAD_MOD_VARIANTDESIGNATOR/g s/ESET_RESOL_MOD/ESET_RESOL_MOD_VARIANTDESIGNATOR/g s/ESETUP_TRANS( *($|\(| |\*))/ESETUP_TRANS_VARIANTDESIGNATOR\1/g s/esetup_trans( *($|\(| |\*|\.h))/esetup_trans_VARIANTDESIGNATOR\1/g s/especnorm/especnorm_VARIANTDESIGNATOR/g s/ESPECNORM/ESPECNORM_VARIANTDESIGNATOR/g s/SPNORM_CTL_MOD/SPNORM_CTL_MOD_VARIANTDESIGNATOR/g s/SPNORMC_MOD/SPNORMC_MOD_VARIANTDESIGNATOR/g s/ESPNORMD_MOD/ESPNORMD_MOD_VARIANTDESIGNATOR/g s/ESPNSDE_MOD/ESPNSDE_MOD_VARIANTDESIGNATOR/g s/ESPNSDEAD_MOD/ESPNSDEAD_MOD_VARIANTDESIGNATOR/g s/etibihie/etibihie_VARIANTDESIGNATOR/g s/ETIBIHIE/ETIBIHIE_VARIANTDESIGNATOR/g s/TPM_FFTW/TPM_FFTW_VARIANTDESIGNATOR/g s/TPM_FLT/TPM_FLT_VARIANTDESIGNATOR/g s/TPM_TRANS/TPM_TRANS_VARIANTDESIGNATOR/g s/TPMALD_FFT/TPMALD_FFT_VARIANTDESIGNATOR/g s/TPMALD_FIELD/TPMALD_FIELD_VARIANTDESIGNATOR/g s/TPMALD_GEO/TPMALD_GEO_VARIANTDESIGNATOR/g s/TPMALD_TCDIS/TPMALD_TCDIS_VARIANTDESIGNATOR/g s/TRGTOL_MOD/TRGTOL_MOD_VARIANTDESIGNATOR/g s/etrans_end( *($|\(| |\*|\.h))/etrans_end_VARIANTDESIGNATOR\1/g s/ETRANS_END/ETRANS_END_VARIANTDESIGNATOR/g s/etrans_inq( *($|\(| |\*))/etrans_inq_VARIANTDESIGNATOR\1/g s/ETRANS_INQ/ETRANS_INQ_VARIANTDESIGNATOR/g s/etrans_release( *($|\(| |\*|\.h))/etrans_release_VARIANTDESIGNATOR\1/g s/ETRANS_RELEASE/ETRANS_RELEASE_VARIANTDESIGNATOR/g s/TRLTOG_MOD/TRLTOG_MOD_VARIANTDESIGNATOR/g s/TRLTOM_MOD/TRLTOM_MOD_VARIANTDESIGNATOR/g s/TRLTOM_PACK_UNPACK/TRLTOM_PACK_UNPACK_VARIANTDESIGNATOR/g s/TRMTOL_MOD/TRMTOL_MOD_VARIANTDESIGNATOR/g s/TRMTOL_PACK_UNPACK/TRMTOL_PACK_UNPACK_VARIANTDESIGNATOR/g s/EUPDSP_MOD/EUPDSP_MOD_VARIANTDESIGNATOR/g s/EUPDSPAD_MOD/EUPDSPAD_MOD_VARIANTDESIGNATOR/g s/EUPDSPB_MOD/EUPDSPB_MOD_VARIANTDESIGNATOR/g s/EUPDSPBAD_MOD/EUPDSPBAD_MOD_VARIANTDESIGNATOR/g s/EUVTVD_MOD/EUVTVD_MOD_VARIANTDESIGNATOR/g s/EUVTVDAD_MOD/EUVTVDAD_MOD_VARIANTDESIGNATOR/g s/EVDTUV_CTL_MOD/EVDTUV_CTL_MOD_VARIANTDESIGNATOR/g s/EVDTUV_MOD/EVDTUV_MOD_VARIANTDESIGNATOR/g s/EVDTUV_MOD/EVDTUV_MOD_VARIANTDESIGNATOR/g s/EVDTUVAD_MOD/EVDTUVAD_MOD_VARIANTDESIGNATOR/g s/EXTPER_MOD/EXTPER_MOD_VARIANTDESIGNATOR/g s/ESPLINE_MOD/ESPLINE_MOD_VARIANTDESIGNATOR/g s/ESMOOTHE_MOD/ESMOOTHE_MOD_VARIANTDESIGNATOR/g s/EWINDOWE_MOD/EWINDOWE_MOD_VARIANTDESIGNATOR/g s/EUVTVD_COMM_MOD/EUVTVD_COMM_MOD_VARIANTDESIGNATOR/g s/EVDTUVAD_COMM_MOD/EVDTUVAD_COMM_MOD_VARIANTDESIGNATOR/g s/SUEFFT_MOD/SUEFFT_MOD_VARIANTDESIGNATOR/g s/SUEMP_TRANS_MOD/SUEMP_TRANS_MOD_VARIANTDESIGNATOR/g s/SUEMP_TRANS_PRELEG_MOD/SUEMP_TRANS_PRELEG_MOD_VARIANTDESIGNATOR/g s/SUESTAONL_MOD/SUESTAONL_MOD_VARIANTDESIGNATOR/g ectrans-1.8.0/src/etrans/gpu/0000775000175000017500000000000015174631767016242 5ustar alastairalastairectrans-1.8.0/src/etrans/gpu/internal/0000775000175000017500000000000015174631767020056 5ustar alastairalastairectrans-1.8.0/src/etrans/gpu/internal/eprfi2b_mod.F900000664000175000017500000000576315174631767022541 0ustar alastairalastairMODULE EPRFI2B_MOD CONTAINS SUBROUTINE EPRFI2B(KFIELD,PFFT,FOUBUF) !**** *EPRFI2B* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *EPRFI2B(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM ! Implicit arguments : FOUBUF in TPM_TRANS ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 90-07-01 ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE PARKIND_ECTRANS, ONLY : JPRBT USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRBT) , INTENT(OUT) :: PFFT(:,:,:) REAL(KIND=JPRBT) , INTENT(IN) :: FOUBUF(:) INTEGER(KIND=JPIM) :: IM, JM INTEGER(KIND=JPIM) :: ISTAN, JF, JGL INTEGER(KIND=JPIM) :: IJR, IJI REAL(KIND=JPRB) :: SCAL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EPRFI2B_MOD:EPRFI2B',0,ZHOOK_HANDLE) !* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. ! ------------------------------------------------ SCAL=1._JPRB/REAL(R%NDGL,JPRB) !$acc data & !$acc& present(PFFT) & !$acc& present(FOUBUF) & !$acc& copyin(R%NDGL,D%NPNTGTB1,D%NPROCL,D%NUMP,D%MYMS,SCAL) !loop over wavenumber !$acc parallel loop collapse(3) private(ISTAN,IM,IJR,IJI,JM) DO JM = 1, D%NUMP DO JF =1,KFIELD DO JGL=1,R%NDGL IM = D%MYMS(JM) IJR = 2*(JF-1)+1 IJI = IJR+1 ISTAN = (D%NPNTGTB1(JM,JGL))*2*KFIELD PFFT(JGL,JM,IJR) = SCAL*FOUBUF(ISTAN+IJR) PFFT(JGL,JM,IJI) = SCAL*FOUBUF(ISTAN+IJI) ENDDO ENDDO ENDDO !$acc end data IF (LHOOK) CALL DR_HOOK('EPRFI2B_MOD:EPRFI2B',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI2B END MODULE EPRFI2B_MODectrans-1.8.0/src/etrans/gpu/internal/eledir_mod.F900000664000175000017500000000635415174631767022451 0ustar alastairalastairMODULE ELEDIR_MOD CONTAINS SUBROUTINE ELEDIR(ALLOCATOR,PFFT,PFFT_OUT) !**** *LEINV* - Inverse Legendre transform. ! Purpose. ! -------- ! Inverse Legendre tranform of all variables(kernel). !** Interface. ! ---------- ! CALL LEINV(...) ! Explicit arguments : KM - zonal wavenumber (input-c) ! -------------------- KFC - number of fields to tranform (input-c) ! PIA - spectral fields ! for zonal wavenumber KM (input) ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PLEPO - Legendre polonomials for zonal ! wavenumber KM (input-c) ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - calls SGEMVX (matrix multiply) ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LEINV in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 01-Sep-2015 support for FFTW transforms ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN, ONLY: NCUR_RESOL USE TPM_DISTR ,ONLY : D USE TPMALD_DIM ,ONLY : RALD USE TPM_HICFFT ,ONLY : EXECUTE_DIR_FFT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE ISO_C_BINDING USE BUFFERED_ALLOCATOR_MOD ! IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PFFT(:,:,:) REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PFFT_OUT(:,:,:) INTEGER(KIND=JPIM) :: JLOT TYPE(C_PTR) :: IPLAN_C2R REAL (KIND=JPRB), POINTER :: ZFFT_L(:), ZFFT_L_OUT(:) ! 1D copy REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('ELEDIR_MOD:ELEDIR',0,ZHOOK_HANDLE) JLOT=UBOUND(PFFT,2)*UBOUND (PFFT,3) CALL C_F_POINTER(C_LOC(PFFT), ZFFT_L, (/UBOUND(PFFT,1)*UBOUND(PFFT,2)*UBOUND(PFFT,3)/) ) CALL C_F_POINTER(C_LOC(PFFT_OUT), ZFFT_L_OUT, (/UBOUND(PFFT_OUT,1)*UBOUND(PFFT_OUT,2)*UBOUND(PFFT_OUT,3)/) ) IF (JLOT==0) THEN IF (LHOOK) CALL DR_HOOK('ELEDIR_MOD:ELEDIR',1,ZHOOK_HANDLE) RETURN ENDIF !$ACC DATA PRESENT(ZFFT_L,ZFFT_L_OUT,RALD%NLOENS_LAT,RALD%NOFFSETS_LAT) CALL EXECUTE_DIR_FFT(ZFFT_L,ZFFT_L_OUT,NCUR_RESOL,-JLOT, & ! -JLOT to have hicfft make distinction between zonal and meridional direction. Don't worry, abs(JLOT) is used internally ... & LOENS=RALD%NLOENS_LAT, & & OFFSETS=RALD%NOFFSETS_LAT,ALLOC=ALLOCATOR%PTR) !$ACC END DATA IF (LHOOK) CALL DR_HOOK('ELEDIR_MOD:ELEDIR',1,ZHOOK_HANDLE) END SUBROUTINE ELEDIR END MODULE ELEDIR_MODectrans-1.8.0/src/etrans/gpu/internal/edir_trans_ctl_mod.F900000664000175000017500000001511715174631767024176 0ustar alastairalastairMODULE EDIR_TRANS_CTL_MOD CONTAINS SUBROUTINE EDIR_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV,AUX_PROC) !**** *EDIR_TRANS_CTL* - Control routine for direct spectral transform. ! Purpose. ! -------- ! Control routine for the direct spectral transform !** Interface. ! ---------- ! CALL EDIR_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity ! PSPDIV(:,:) - spectral divergence ! PSPSCALAR(:,:) - spectral scalarvalued fields ! 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. ! PMEANU,PMEANV - mean winds ! AUX_PROC - optional external procedure for biperiodization of ! aux.fields ! PGP(:,:,:) - gridpoint fields ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! G. Radnoti 01-03-13 adaptation to aladin ! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 ! 02-09-30 : P. Smolikova AUX_PROC for d4 in NH ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NPROMATR USE TPM_TRANS ,ONLY : GROWING_ALLOCATION USE ELTDIR_MOD USE TRLTOM_PACK_UNPACK, ONLY : TRLTOM_PACK, TRLTOM_PACK_HANDLE, PREPARE_TRLTOM_PACK USE TRLTOM_MOD USE FTDIR_MOD USE EFTDIR_MOD USE TRGTOL_MOD USE BUFFERED_ALLOCATOR_MOD IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS 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(:,:) 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(:) 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(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANV(:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC ! Local variables REAL(KIND=JPRB), POINTER :: FOUBUF(:), FOUBUF_IN(:), PREEL(:), PREEL_COMPLEX(:) TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR TYPE(FTDIR_HANDLE) :: HFTDIR TYPE(ELTDIR_HANDLE) :: HELTDIR TYPE(TRLTOM_HANDLE) :: HTRLTOM TYPE(TRLTOM_PACK_HANDLE) :: HTRLTOM_PACK TYPE(TRGTOL_HANDLE) :: HTRGTOL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Perform transform IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTL_MOD:EDIR_TRANS_CTL',0,ZHOOK_HANDLE) IF(NPROMATR > 0) THEN print *, "This is currently not supported and/or tested (NPROMATR > 0)" stop 24 ENDIF ! Prepare everything ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() HTRGTOL = PREPARE_TRGTOL(ALLOCATOR,KF_GP,KF_FS) ! ZCOMBUFR, ZCOMBUFS and PREEL IF (KF_FS > 0) THEN HFTDIR = PREPARE_FTDIR(ALLOCATOR,KF_FS) ! PREEL_COMPLEX HTRLTOM_PACK = PREPARE_TRLTOM_PACK(ALLOCATOR, KF_FS) ! FOUBUF_IN HTRLTOM = PREPARE_TRLTOM(ALLOCATOR, KF_FS) ! FOUBUF HELTDIR = PREPARE_ELTDIR(ALLOCATOR, KF_FS, KF_UV) ENDIF CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) ! from the PGP arrays to PREEL_REAL CALL TRGTOL(ALLOCATOR,HTRGTOL,PREEL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) IF (KF_FS > 0) THEN ! fourier transform from PREEL_REAL to PREEL_COMPLEX (in-place!) CALL GSTATS(1640,0) CALL EFTDIR(ALLOCATOR,HFTDIR,PREEL,PREEL_COMPLEX,KF_FS,AUX_PROC=AUX_PROC) CALL GSTATS(1640,1) CALL GSTATS(153,0) CALL TRLTOM_PACK(ALLOCATOR,HTRLTOM_PACK,PREEL_COMPLEX,FOUBUF_IN,KF_FS) ! formerly known as efourier_out CALL TRLTOM(ALLOCATOR,HTRLTOM,FOUBUF_IN,FOUBUF,KF_FS) CALL GSTATS(153,1) CALL ELTDIR(ALLOCATOR,HELTDIR,KF_FS,KF_UV,KF_SCALARS,FOUBUF, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2, & & PSPMEANU=PMEANU,PSPMEANV=PMEANV) ENDIF IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTL_MOD:EDIR_TRANS_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EDIR_TRANS_CTL END MODULE EDIR_TRANS_CTL_MOD ectrans-1.8.0/src/etrans/gpu/internal/eprfi1b_mod.F900000664000175000017500000000656015174631767022534 0ustar alastairalastairMODULE EPRFI1B_MOD CONTAINS SUBROUTINE EPRFI1B(PFFT,PSPEC,KFIELDS,KFLDPTR) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DIM USE TPM_DISTR, ONLY : D USE TPMALD_DISTR ,ONLY : DALD ! !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1B(...)* ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPEC - spectral array ! KFIELDS - number of fields ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1B in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(OUT) :: PFFT(:,:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF INTEGER(KIND=JPIM) :: IM, JM, MAX_NCPL2M INTEGER(KIND=JPIM) :: JFLDPTR(KFIELDS) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- IF (LHOOK) CALL DR_HOOK('EPRFI1B_MOD:EPRFI1B',0,ZHOOK_HANDLE) IF (PRESENT(KFLDPTR)) THEN JFLDPTR=KFLDPTR ELSE DO JFLD=1,KFIELDS JFLDPTR(JFLD)=JFLD ENDDO ENDIF !$acc data present (PFFT, PSPEC) !!$acc kernels default(none) !PFFT = 0._JPRB !!$acc end kernels MAX_NCPL2M = MAXVAL (DALD%NCPL2M) !$ACC parallel loop collapse(3) & !$ACC& present(D,DALD,D%MYMS,DALD%NCPL2M,DALD%NESM0,D%NUMP) & !$ACC& copyin(KFIELDS,MAX_NCPL2M,JFLDPTR) & !$ACC& private(IR,II,IM,ILCM,IOFF,INM,JFLD) default(none) DO JM = 1, D%NUMP DO JFLD=1,KFIELDS DO J=1,MAX_NCPL2M,2 IR = 2*JFLD-1 II = IR+1 IM = D%MYMS(JM) ILCM = DALD%NCPL2M(IM) IF (J .LE. ILCM) THEN IOFF = DALD%NESM0(IM) INM = IOFF+(J-1)*2 PFFT(J ,JM,IR) = PSPEC(JFLDPTR(JFLD),INM ) PFFT(J+1,JM,IR) = PSPEC(JFLDPTR(JFLD),INM+1) PFFT(J ,JM,II) = PSPEC(JFLDPTR(JFLD),INM+2) PFFT(J+1,JM,II) = PSPEC(JFLDPTR(JFLD),INM+3) ELSE PFFT(J ,JM,IR) = 0._JPRB PFFT(J+1,JM,IR) = 0._JPRB PFFT(J ,JM,II) = 0._JPRB PFFT(J+1,JM,II) = 0._JPRB ENDIF ENDDO ENDDO ENDDO !$acc end data IF (LHOOK) CALL DR_HOOK('EPRFI1B_MOD:EPRFI1B',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI1B END MODULE EPRFI1B_MODectrans-1.8.0/src/etrans/gpu/internal/eltdir_mod.F900000664000175000017500000001771415174631767022472 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) MODULE ELTDIR_MOD USE BUFFERED_ALLOCATOR_MOD IMPLICIT NONE PRIVATE PUBLIC :: ELTDIR, ELTDIR_HANDLE, PREPARE_ELTDIR TYPE ELTDIR_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFFT TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFFT_OUT TYPE(ALLOCATION_RESERVATION_HANDLE) :: HVODI END TYPE CONTAINS FUNCTION PREPARE_ELTDIR(ALLOCATOR,KF_FS,KF_UV) RESULT(HELTDIR) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD USE TPM_DISTR, ONLY: D USE TPM_DIM, ONLY: R USE TPMALD_DIM ,ONLY : RALD USE ISO_C_BINDING !USE LEINV_MOD IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) ::KF_FS, KF_UV TYPE(ELTDIR_HANDLE) :: HELTDIR INTEGER(KIND=C_SIZE_T) :: IALLOC_SZ REAL(KIND=JPRBT) :: ZPRBT_DUMMY ! ZFFT IALLOC_SZ = ALIGN(1_JPIB*(RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*2*KF_FS*SIZEOF(ZPRBT_DUMMY), 128) HELTDIR%HFFT = RESERVE(ALLOCATOR, IALLOC_SZ) ! ZFFT_OUT #ifndef IN_PLACE_FFT IALLOC_SZ = ALIGN(1_JPIB*(RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*2*KF_FS*SIZEOF(ZPRBT_DUMMY), 128) HELTDIR%HFFT_OUT = RESERVE(ALLOCATOR, IALLOC_SZ) #endif ! ZVODI IALLOC_SZ = ALIGN(1_JPIB*(RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*MAX(4*KF_UV,1)*SIZEOF(ZPRBT_DUMMY), 128) HELTDIR%HVODI = RESERVE(ALLOCATOR, IALLOC_SZ) END FUNCTION PREPARE_ELTDIR SUBROUTINE ELTDIR(ALLOCATOR,HELTDIR,KF_FS,KF_UV,KF_SCALARS,FOUBUF,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) USE ISO_C_BINDING USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPMALD_DIM ,ONLY : RALD USE EPRFI2B_MOD ,ONLY : EPRFI2B USE ELEDIR_MOD ,ONLY : ELEDIR USE EUVTVD_MOD USE EUVTVD_COMM_MOD USE EUPDSP_MOD ,ONLY : EUPDSP USE EXTPER_MOD ,ONLY : EXTPER ! !**** *ELTDIR* - Control of Direct Legendre transform step ! Purpose. ! -------- ! Tranform from Fourier space to spectral space, compute ! vorticity and divergence. !** Interface. ! ---------- ! *CALL* *ELTDIR(...)* ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! EPRFI2 - prepares the Fourier work arrays for model variables ! ELEDIR - direct Legendre transform ! EUVTVD - ! EUPDSP - updating of spectral arrays (fields) ! EUVTVD_COMM - ! EXTPER - ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-24 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified 94-04-06 R. El khatib Full-POS implementation ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group : 95-10-01 Support for Distributed Memory version ! K. YESSAD (AUGUST 1996): ! - Legendre transforms for transmission coefficients. ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! 01-03-14 G. Radnoti aladin version ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(ELTDIR_HANDLE), INTENT(IN) :: HELTDIR INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS REAL(KIND=JPRB), INTENT(IN) :: FOUBUF(:) 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) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANV(:) INTEGER(KIND=JPIM) :: IM, JM INTEGER(KIND=JPIM) :: IUS,IVS,IVORS,IDIVS, IUE, IVE, IVORE, IDIVE REAL(KIND=JPRB), POINTER :: ZFFT(:,:,:), ZFFT_L(:), ZFFT_OUT(:,:,:), ZFFT_L_OUT(:) REAL(KIND=JPRB), POINTER :: ZVODI(:,:,:), ZVODI_L(:) INTEGER(KIND=C_SIZE_T) :: IALLOC_SZ REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ELTDIR_MOD:ELTDIR',0,ZHOOK_HANDLE) ! ZFFT(RALD%NDGLSUR+R%NNOEXTZG,2*KF_FS,D%NUMP) IALLOC_SZ = ALIGN((RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*2*KF_FS*SIZEOF(ZFFT_L(1)), 128) CALL ASSIGN_PTR(ZFFT_L, GET_ALLOCATION(ALLOCATOR, HELTDIR%HFFT),& & 1_JPIB, IALLOC_SZ) CALL C_F_POINTER(C_LOC(ZFFT_L), ZFFT, (/ RALD%NDGLSUR+R%NNOEXTZG,D%NUMP,2*KF_FS /)) !* 1. PREPARE WORK ARRAYS. ! -------------------- CALL EPRFI2B(KF_FS,ZFFT,FOUBUF) !* 2. PERIODICIZATION IN Y DIRECTION ! ------------------------------ IF(R%NNOEXTZG>0) THEN CALL ABORT('NNOEXTZG>0 not supported on GPU') ENDIF !* 3. DIRECT LEGENDRE TRANSFORM. ! -------------------------- #ifdef IN_PLACE_FFT ZFFT_OUT => ZFFT #else IALLOC_SZ = ALIGN((RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*2*KF_FS*SIZEOF(ZFFT_L(1)), 128) CALL ASSIGN_PTR(ZFFT_L_OUT, GET_ALLOCATION(ALLOCATOR, HELTDIR%HFFT_OUT),& & 1_JPIB, IALLOC_SZ) CALL C_F_POINTER(C_LOC(ZFFT_L_OUT), ZFFT_OUT, (/ RALD%NDGLSUR+R%NNOEXTZG,D%NUMP,2*KF_FS /)) #endif CALL ELEDIR(ALLOCATOR,ZFFT,ZFFT_OUT) !* 4. COMPUTE VORTICITY AND DIVERGENCE AND STORE MEAN WIND ON TASK OWNING WAVE 0 ! -------------------------------------------------------------------------- ! ZVODI(RALD%NDGLSUR+R%NNOEXTZG,MAX(4*KF_UV,1),D%NUMP) IALLOC_SZ = ALIGN((RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*MAX(4*KF_UV,1)*SIZEOF(ZVODI_L(1)), 128) CALL ASSIGN_PTR(ZVODI_L, GET_ALLOCATION(ALLOCATOR, HELTDIR%HVODI),& & 1_JPIB, IALLOC_SZ) CALL C_F_POINTER(C_LOC(ZVODI_L), ZVODI, (/ RALD%NDGLSUR+R%NNOEXTZG,D%NUMP,MAX(4*KF_UV,1) /)) #ifdef ACCGPU !$ACC DATA COPYOUT(PSPVOR,PSPDIV) IF(KF_UV > 0) !$ACC DATA COPYOUT(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$ACC DATA COPYOUT(PSPSC2) IF(PRESENT(PSPSC2)) !$ACC DATA COPYOUT(PSPSC3A) IF((PRESENT(PSPSC3A))) !$ACC DATA COPYOUT(PSPSC3B) IF((PRESENT(PSPSC3B))) #endif IF( KF_UV > 0 ) THEN IUS = 1 IUE = 2*KF_UV IVS = 2*KF_UV+1 IVE = 4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV CALL EUVTVD(KF_UV,ZFFT_OUT(:,:,IUS:IUE),ZFFT_OUT(:,:,IVS:IVE),& & ZVODI(:,:,IVORS:IVORE),ZVODI(:,:,IDIVS:IDIVE)) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL EUVTVD_COMM(IM,JM,KF_UV,KFLDPTRUV,ZFFT_OUT(:,:,IUS:IUE), & & ZFFT_OUT(:,:,IVS:IVE), & & PSPMEANU,PSPMEANV) ENDDO ENDIF !* 5. UPDATE SPECTRAL ARRAYS. ! ----------------------- CALL EUPDSP(KF_UV,KF_SCALARS,ZFFT_OUT,ZVODI, & & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,KFLDPTRUV,KFLDPTRSC) #ifdef ACCGPU !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('ELTDIR_MOD:ELTDIR',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTDIR END MODULE ELTDIR_MOD ectrans-1.8.0/src/etrans/gpu/internal/eupdsp_mod.F900000664000175000017500000001002015174631767022466 0ustar alastairalastairMODULE EUPDSP_MOD CONTAINS SUBROUTINE EUPDSP(KF_UV,KF_SCALARS,PFFT,PVODI, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) !**** *EUPDSP* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update the spectral arrays for a fixed zonal wave-number ! from values in POA1 and POA2. !** Interface. ! ---------- ! CALL EUPDSP(...) ! Explicit arguments : ! -------------------- ! POA1 - spectral fields for zonal wavenumber KM (basic var.) ! POA2 - spectral fields for zonal wavenumber KM (vor. div.) ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Externals. UPDSPB - basic transfer routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 94-08-02 R. El Khatib - interface to UPDSPB ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B !USE TPM_DISTR USE EUPDSPB_MOD ,ONLY : EUPDSPB ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS REAL(KIND=JPRB) , INTENT(IN) :: PFFT(:,:,:) REAL(KIND=JPRB) , INTENT(IN) :: PVODI(:,:,:) 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) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND,IDIM1,IDIM3,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. UPDATE FIELDS ! ------------- !* 1.1 VORTICITY AND DIVERGENCE. IF (LHOOK) CALL DR_HOOK('EUPDSP_MOD:EUPDSP',0,ZHOOK_HANDLE) IST = 1 IF (KF_UV > 0) THEN IST = IST+4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV CALL EUPDSPB(KF_UV,PVODI(:,:,IVORS:IVORE),PSPVOR,KFLDPTRUV) CALL EUPDSPB(KF_UV,PVODI(:,:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) ENDIF !* 1.2 SCALARS IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IEND = IST+2*KF_SCALARS-1 CALL EUPDSPB(KF_SCALARS,PFFT(:,:,IST:IEND),PSPSCALAR,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IDIM1 = NF_SC2 IEND = IST+2*IDIM1-1 CALL EUPDSPB(IDIM1,PFFT(:,:,IST:IEND),PSPSC2) IST=IST+2*IDIM1 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL EUPDSPB(IDIM1,PFFT(:,:,IST:IEND),PSPSC3A(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL EUPDSPB(IDIM1,PFFT(:,:,IST:IEND),PSPSC3B(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('EUPDSP_MOD:EUPDSP',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EUPDSP END MODULE EUPDSP_MODectrans-1.8.0/src/etrans/gpu/internal/eupdspb_mod.F900000664000175000017500000000557115174631767022647 0ustar alastairalastairMODULE EUPDSPB_MOD CONTAINS SUBROUTINE EUPDSPB(KFIELD,POA,PSPEC,KFLDPTR) !**** *EUPDSPB* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update spectral arrays for a fixed zonal wave-number ! from values in POA. !** Interface. ! ---------- ! CALL EUPDSPB(....) ! Explicit arguments : ! -------------------- KFIELD - number of fields ! POA - work array ! PSPEC - spectral array ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the ! first and last field ! L. Isaksen : 95-06-06 Reordering of spectral arrays ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPMALD_DISTR ,ONLY : DALD USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRB) ,INTENT(IN) :: POA(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN,IFLD, JM, IM INTEGER(KIND=JPIM) :: JFLDPTR(KFIELD) INTEGER(KINd=JPIM) :: MAX_NCPL2M REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. UPDATE SPECTRAL FIELDS. ! ----------------------- IF (LHOOK) CALL DR_HOOK('EUPDSPB_MOD:EUPDSPB',0,ZHOOK_HANDLE) !$ACC data present (POA, PSPEC) IF(PRESENT(KFLDPTR)) THEN JFLDPTR=KFLDPTR ELSE DO JFLD=1,KFIELD JFLDPTR(JFLD)=JFLD ENDDO ENDIF MAX_NCPL2M = MAXVAL (DALD%NCPL2M) !$ACC parallel loop collapse(3) & !$acc& copyin(MAX_NCPL2M,KFIELD,JFLDPTR) & !$acc& present(D%NUMP,D%MYMS,DALD%NESM0,DALD%NCPL2M) & !$acc& private(JM,JN,JFLD,IM,INM,IR,II ) DO JN=1,MAX_NCPL2M,2 DO JM = 1, D%NUMP DO JFLD=1,KFIELD IM = D%MYMS(JM) INM=DALD%NESM0(IM)+(JN-1)*2 if ( JN .LE. DALD%NCPL2M(IM) ) then IR= 2*JFLD-1 II=IR+1 PSPEC(JFLDPTR(JFLD),INM) =POA(JN ,JM,IR) PSPEC(JFLDPTR(JFLD),INM+1) =POA(JN+1,JM,IR) PSPEC(JFLDPTR(JFLD),INM+2) =POA(JN ,JM,II) PSPEC(JFLDPTR(JFLD),INM+3) =POA(JN+1,JM,II) endif ENDDO ENDDO ENDDO !$ACC end data IF (LHOOK) CALL DR_HOOK('EUPDSPB_MOD:EUPDSPB',1,ZHOOK_HANDLE) END SUBROUTINE EUPDSPB END MODULE EUPDSPB_MODectrans-1.8.0/src/etrans/gpu/internal/suemp_trans_mod.F900000664000175000017500000002037115174631767023540 0ustar alastairalastairMODULE SUEMP_TRANS_MOD CONTAINS SUBROUTINE SUEMP_TRANS ! Set up distributed environment for the transform package (part 2) ! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, NPRTRNS, NPRTRW, MYSETW, NPROC, MYPROC USE TPMALD_DIM ,ONLY : RALD USE SUMPLATF_MOD ,ONLY : SUMPLATF USE SUEMPLAT_MOD ,ONLY : SUEMPLAT USE SUESTAONL_MOD ,ONLY : SUESTAONL USE MYSENDSET_MOD ,ONLY : MYSENDSET USE MYRECVSET_MOD ,ONLY : MYRECVSET USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & & N_REGIONS, N_REGIONS_EW, N_REGIONS_NS ! IMPLICIT NONE INTEGER(KIND=JPIM) :: JM INTEGER(KIND=JPIM) :: JGL,IGL,IPLAT,ISENDSET,IRECVSET,JML,IPOS,IM INTEGER(KIND=JPIM) :: I1,I2,I3,IAUX0,IAUX1,JA1 INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF INTEGER(KIND=JPIM), ALLOCATABLE :: IGPTOTL(:,:) REAL(KIND=JPRD) :: ZMEDIAP LOGICAL :: LLP1,LLP2 REAL(KIND=JPRD),ALLOCATABLE :: ZDUM(:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_MOD:SUEMP_TRANS',0,ZHOOK_HANDLE) LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEMP_TRANS ===' IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NULTPP(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NULTPP ',SIZE(D%NULTPP ),SHAPE(D%NULTPP ) ALLOCATE(D%NPTRLS(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLS ',SIZE(D%NPTRLS ),SHAPE(D%NPTRLS ) ALLOCATE(D%NPROCL(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCL ',SIZE(D%NPROCL ),SHAPE(D%NPROCL ) CALL SUMPLATF(R%NDGL,NPRTRNS,MYSETW,D%NULTPP,D%NPROCL,D%NPTRLS) D%NDGL_FS = D%NULTPP(MYSETW) ! Help arrays for spectral to fourier space transposition ALLOCATE(D%NLTSGTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSGTB ',SIZE(D%NLTSGTB),SHAPE(D%NLTSGTB) ALLOCATE(D%NLTSFTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSFTB ',SIZE(D%NLTSFTB),SHAPE(D%NLTSFTB) ALLOCATE(D%NSTAGT0B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT0B ',SIZE(D%NSTAGT0B),SHAPE(D%NSTAGT0B) ALLOCATE(D%NSTAGT1B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT1B ',SIZE(D%NSTAGT1B),SHAPE(D%NSTAGT1B) ALLOCATE(D%MSTABF (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%MSTABF ',SIZE(D%MSTABF),SHAPE(D%MSTABF) D%NLTSGTB(:) = 0 DO JGL=1,D%NDGL_FS IGL = D%NPTRLS(MYSETW)+JGL-1 DO JM=0,G%NMEN(IGL) D%NLTSGTB(D%NPROCM(JM)) = D%NLTSGTB(D%NPROCM(JM))+1 ENDDO ENDDO DO JA=1,NPRTRW IPLAT = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA)+JGL-1 DO JM=1,D%NUMP IF(IGL > R%NDGNH-G%NDGLU(D%MYMS(JM)) .AND. IGL <= R%NDGNH+G%NDGLU(D%MYMS(JM))) THEN IPLAT = IPLAT + 1 ENDIF ENDDO ENDDO D%NLTSFTB(JA) = IPLAT ENDDO DO JA=1,NPRTRW-1 ISENDSET = MYSENDSET(NPRTRW,MYSETW,JA) IRECVSET = MYRECVSET(NPRTRW,MYSETW,JA) D%MSTABF(IRECVSET) = ISENDSET ENDDO D%MSTABF(MYSETW) = MYSETW ALLOCATE(D%NPNTGTB0(0:RALD%NMSMAX,D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB0 ',SIZE(D%NPNTGTB0 ),SHAPE(D%NPNTGTB0 ) ALLOCATE(D%NPNTGTB1(D%NUMP,R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB1 ',SIZE(D%NPNTGTB1 ),SHAPE(D%NPNTGTB1 ) ! Global offsets of processors D%NSTAGT0B(1) = 0 D%NSTAGT1B(1) = 0 DO JA=2,NPRTRNS D%NSTAGT0B(JA) = D%NSTAGT0B(JA-1)+D%NLTSGTB(JA-1) D%NSTAGT1B(JA) = D%NSTAGT1B(JA-1)+D%NLTSFTB(JA-1) ENDDO ! Global size of foubuf D%NLENGT0B = D%NSTAGT0B(NPRTRNS)+D%NLTSGTB(NPRTRNS) D%NLENGT1B = D%NSTAGT1B(NPRTRNS)+D%NLTSFTB(NPRTRNS) DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(MYSETW) IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JML=D%NPTRMS(JA),D%NPTRMS(JA)+D%NUMPP(JA)-1 IM = D%NALLMS(JML) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB0(IM,JGL) = D%NSTAGT0B(D%NPROCM(IM))+IPOS IPOS = IPOS+1 ELSE D%NPNTGTB0(IM,JGL) = -99 ENDIF ENDDO ENDDO ENDDO DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA) + JGL - 1 DO JM=1,D%NUMP IM = D%MYMS(JM) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB1(JM,IGL) = D%NSTAGT1B(D%NPROCL(IGL))+IPOS IPOS = IPOS+1 ELSE D%NPNTGTB1(JM,IGL) = -99 ENDIF ENDDO ENDDO ENDDO ENDIF ! GRIDPOINT SPACE ALLOCATE(D%NFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NFRSTLAT ',SIZE(D%NFRSTLAT ),SHAPE(D%NFRSTLAT ) ALLOCATE(D%NLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NLSTLAT ',SIZE(D%NLSTLAT ),SHAPE(D%NLSTLAT ) ALLOCATE(D%NPTRLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLAT ',SIZE(D%NPTRLAT ),SHAPE(D%NPTRLAT ) ALLOCATE(D%NPTRFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRFRSTLAT',SIZE(D%NPTRFRSTLAT),SHAPE(D%NPTRFRSTLAT) ALLOCATE(D%NPTRLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9)'D%NPTRLSTLAT',SIZE(D%NPTRLSTLAT),SHAPE(D%NPTRLSTLAT) ALLOCATE(D%LSPLITLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%LSPLITLAT',SIZE(D%LSPLITLAT),SHAPE(D%LSPLITLAT) ALLOCATE(D%NPROCA_GP(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCA_GP',SIZE(D%NPROCA_GP),SHAPE(D%NPROCA_GP) IF(.NOT.D%LWEIGHTED_DISTR) THEN ALLOCATE(ZDUM(1)) CALL SUEMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT, LEQ_REGIONS,& & D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& & D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& & ZDUM,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& & IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN,RALD%NDGUX) ELSE CALL SUEMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT, LEQ_REGIONS,& & D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& & D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& & D%RWEIGHT,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& & IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN,RALD%NDGUX) ENDIF D%NDGL_GP = D%NLSTLAT(MY_REGION_NS)-D%NFRSTLOFF IF (LLP1) THEN IF(.NOT.D%LGRIDONLY) THEN WRITE(NOUT,FMT='(/'' OUTPUT FROM ROUTINE SUEMPLAT: ''/)') WRITE(NOUT,FMT='('' D%NULTPP '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NULTPP(1:NPRTRNS) WRITE(NOUT,FMT='('' D%NPROCL '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPROCL(1:R%NDGL) ENDIF WRITE(NOUT,FMT='('' D%NFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NFRSTLOFF D%NPTRFLOFF '')') WRITE(NOUT,FMT='(2(1X,I6))') D%NFRSTLOFF, D%NPTRFLOFF WRITE(NOUT,FMT='('' D%NPTRLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%LSPLITLAT '')') WRITE(NOUT,FMT='(50(1X,L1))') D%LSPLITLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%NPTRFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NPTRLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='(/)') ENDIF ALLOCATE(D%NSTA(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NSTA ',SIZE(D%NSTA ),SHAPE(D%NSTA ) ALLOCATE(D%NONL(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NONL ',SIZE(D%NONL ),SHAPE(D%NONL ) IF(.NOT.D%LWEIGHTED_DISTR) THEN CALL SUESTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,ZDUM,ZMEDIAP,D%NPROCA_GP) ELSE CALL SUESTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,D%RWEIGHT,ZMEDIAP,D%NPROCA_GP) ENDIF ! IGPTOTL is the number of grid points in each individual processor ALLOCATE(IGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IGPTOTL(:,:)=0 DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) IGPTOT = 0 DO JGL=D%NPTRFRSTLAT(JA),D%NPTRLSTLAT(JA) IGPTOT = IGPTOT+D%NONL(JGL,JB) ENDDO IGPTOTL(JA,JB) = IGPTOT ENDDO ENDDO D%NGPTOT = IGPTOTL(MY_REGION_NS,MY_REGION_EW) D%NGPTOTMX = MAXVAL(IGPTOTL) D%NGPTOTG = SUM(IGPTOTL) ALLOCATE(D%NGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NGPTOTL ',SIZE(D%NGPTOTL ),SHAPE(D%NGPTOTL ) D%NGPTOTL(:,:) = IGPTOTL(:,:) IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NSTAGTF(D%NDGL_FS+1)) ! NDGL_FS+1 needed in trmtol_unpack IF(LLP2)WRITE(NOUT,9) 'D%NSTAGTF ',SIZE(D%NSTAGTF ),SHAPE(D%NSTAGTF ) IOFF = 0 DO JGL=1,D%NDGL_FS D%NSTAGTF(JGL) = IOFF IGL = D%NPTRLS(MYSETW) + JGL - 1 IOFF = IOFF + G%NLOEN(IGL)+2+R%NNOEXTZL ENDDO D%NSTAGTF(D%NDGL_FS+1) = IOFF D%NLENGTF = IOFF ENDIF IF(ALLOCATED(ZDUM)) DEALLOCATE(ZDUM) DEALLOCATE(IGPTOTL) IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_MOD:SUEMP_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUEMP_TRANS END MODULE SUEMP_TRANS_MOD ectrans-1.8.0/src/etrans/gpu/internal/espnorm_ctl_mod.F900000664000175000017500000000337615174631767023533 0ustar alastairalastairMODULE ESPNORM_CTL_MOD CONTAINS SUBROUTINE ESPNORM_CTL(PSPEC,KFLD,KFLD_G,KVSET,KMASTER,PMET,PNORM) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, MYSETV, MYPROC USE ESPNORMD_MOD ,ONLY : ESPNORMD USE SPNORMC_MOD ,ONLY : SPNORMC USE TPMALD_DIM ,ONLY : RALD ! IMPLICIT NONE REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PNORM(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFLD,KFLD_G INTEGER(KIND=JPIM) :: IVSET(KFLD_G) REAL(KIND=JPRB) :: ZMET(0:R%NSPEC_G) REAL(KIND=JPRB) :: ZSM(KFLD,D%NUMP) REAL(KIND=JPRB) :: ZGM(KFLD_G,0:RALD%NMSMAX) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE1 ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:ESPNORM_CTL',0,ZHOOK_HANDLE) IF(PRESENT(KVSET)) THEN IVSET(:) = KVSET(:) ELSE IVSET(:) = MYSETV ENDIF IF(PRESENT(PMET)) THEN ZMET(:) = PMET(:) ELSE ZMET(:) = 1.0_JPRB ENDIF CALL ESPNORMD(PSPEC,KFLD,ZMET,ZSM) IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:SPNORMC',0,ZHOOK_HANDLE1) CALL SPNORMC(ZSM,KFLD_G,IVSET,KMASTER,RALD%NMSMAX,ZGM) IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:SPNORMC',1,ZHOOK_HANDLE1) IF(MYPROC == KMASTER) THEN PNORM(1:KFLD_G) = SUM(ZGM,DIM=2) PNORM(1:KFLD_G) = SQRT(PNORM(1:KFLD_G)) ENDIF IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:ESPNORM_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESPNORM_CTL END MODULE ESPNORM_CTL_MOD ectrans-1.8.0/src/etrans/gpu/internal/euvtvd_mod.F900000664000175000017500000001001215174631767022504 0ustar alastairalastairMODULE EUVTVD_MOD CONTAINS SUBROUTINE EUVTVD(KFIELD,PU,PV,PVOR,PDIV) !**** *EUVTVD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX - calculation part. !** Interface. ! ---------- ! CALL EUVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number ! -------------------- KFIELD - number of fields (levels) ! KFLDPTR - fields pointers ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! 03-03-03 : G. Radnoti: b-level conform mean-wind distribution ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPMALD_GEO ,ONLY : GALD USE TPMALD_DISTR ,ONLY : DALD ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:,:),PV (:,:,:) REAL(KIND=JPRB), INTENT(OUT) :: PVOR(:,:,:),PDIV(:,:,:) INTEGER(KIND=JPIM) :: II, IN, IR, J, JN INTEGER(KIND=JPIM) :: IM, JM, JNMAX REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EUVTVD_MOD:EUVTVD',0,ZHOOK_HANDLE) !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ !$acc parallel loop collapse(3) private(J,JM,JN,IR,II,IM,ZKM) present (PVOR, PDIV, PU, PV,D%MYMS,D%NUMP) DO J=1,KFIELD DO JM=1,D%NUMP DO JN=1,R%NDGL+R%NNOEXTZG IM = D%MYMS(JM) ZKM=REAL(IM,JPRB)*GALD%EXWN IR=2*J-1 II=IR+1 PDIV(JN,JM,IR)=-ZKM*PU(JN,JM,II) PDIV(JN,JM,II)= ZKM*PU(JN,JM,IR) PVOR(JN,JM,IR)=-ZKM*PV(JN,JM,II) PVOR(JN,JM,II)= ZKM*PV(JN,JM,IR) ENDDO ENDDO ENDDO !$acc end parallel loop JNMAX = MAXVAL(DALD%NCPL2M) !$acc parallel loop collapse(3) private(J,JM,JN,IM,ZIN,IN) copyin (JNMAX) present (PVOR, PDIV, PU, PV,DALD%NCPL2M,D%NUMP,D%MYMS) DO J=1,2*KFIELD DO JM=1,D%NUMP DO JN=1,JNMAX,2 IM = D%MYMS(JM) IF ( JN <= DALD%NCPL2M(IM) ) THEN ! should be here, but doesn't work !? IN=(JN-1)/2 ZIN=REAL(IN,JPRB)*GALD%EYWN PVOR(JN ,JM,J)=PVOR(JN ,JM,J)+ZIN*PU(JN+1,JM,J) PVOR(JN+1,JM,J)=PVOR(JN+1,JM,J)-ZIN*PU(JN ,JM,J) PDIV(JN ,JM,J)=PDIV(JN ,JM,J)-ZIN*PV(JN+1,JM,J) PDIV(JN+1,JM,J)=PDIV(JN+1,JM,J)+ZIN*PV(JN ,JM,J) ELSE PVOR(JN ,JM,J)=0._JPRB PVOR(JN+1,JM,J)=0._JPRB PDIV(JN ,JM,J)=0._JPRB PDIV(JN+1,JM,J)=0._JPRB ENDIF ENDDO ENDDO ENDDO !$acc end parallel loop IF (LHOOK) CALL DR_HOOK('EUVTVD_MOD:EUVTVD',1,ZHOOK_HANDLE) END SUBROUTINE EUVTVD END MODULE EUVTVD_MODectrans-1.8.0/src/etrans/gpu/internal/eftinv_mod.F900000664000175000017500000000333115174631767022470 0ustar alastairalastairMODULE EFTINV_MOD CONTAINS SUBROUTINE EFTINV(ALLOCATOR,HFTINV,PREEL,PREEL_REAL,KF_FS) USE PARKIND1 ,ONLY : JPIM, JPRB, JPIB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN, ONLY : NCUR_RESOL USE TPM_DISTR ,ONLY : D USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_HICFFT ,ONLY : EXECUTE_INV_FFT USE FTINV_MOD, ONLY : FTINV_HANDLE USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE ISO_C_BINDING USE BUFFERED_ALLOCATOR_MOD ! IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(FTINV_HANDLE), INTENT(IN) :: HFTINV REAL(KIND=JPRB), POINTER, INTENT(INOUT) :: PREEL(:) ! (IRLEN+2)*KF_FS*NDGL_FS REAL(KIND=JPRB), POINTER, INTENT(OUT) :: PREEL_REAL(:) ! (IRLEN+2)*KF_FS*NDGL_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM) :: JLOT, IRLEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('EFTINV_MOD:EFTINV',0,ZHOOK_HANDLE) IRLEN=R%NDLON+R%NNOEXTZG #ifdef IN_PLACE_FFT PREEL_REAL => PREEL #else CALL ASSIGN_PTR(PREEL_REAL, GET_ALLOCATION(ALLOCATOR, HFTINV%HREEL_REAL),& & 1_JPIB, 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(PREEL_REAL(1))) #endif JLOT=SIZE(PREEL)/(IRLEN+2) IF (JLOT==0) THEN IF (LHOOK) CALL DR_HOOK('EFTINV_MOD:EFTINV',1,ZHOOK_HANDLE) RETURN ENDIF !$ACC DATA PRESENT(PREEL,RALD%NLOENS_LON,RALD%NOFFSETS_LON) CALL EXECUTE_INV_FFT(PREEL,PREEL_REAL,NCUR_RESOL,JLOT, & & LOENS=RALD%NLOENS_LON, & & OFFSETS=RALD%NOFFSETS_LON,ALLOC=ALLOCATOR%PTR) !$ACC END DATA IF (LHOOK) CALL DR_HOOK('EFTINV_MOD:EFTINV',1,ZHOOK_HANDLE) END SUBROUTINE EFTINV END MODULE EFTINV_MODectrans-1.8.0/src/etrans/gpu/internal/evdtuv_mod.F900000664000175000017500000001141715174631767022516 0ustar alastairalastairMODULE EVDTUV_MOD CONTAINS SUBROUTINE EVDTUV(KFIELD,KFLDPTR,PVOR,PDIV,PU,PV,PSPMEANU,PSPMEANV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPMALD_FIELDS ,ONLY : FALD USE TPMALD_GEO ,ONLY : GALD USE TPMALD_DISTR ,ONLY : DALD USE TPM_DISTR ,ONLY : D USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !**** *VDTUV* - Compute U,V in spectral space ! Purpose. ! -------- ! In Laplace space compute the the winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL VDTUV(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! KFLDPTR - fields pointers ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PVOR(NLEI1,2*KFIELD) - vorticity (input) ! PDIV(NLEI1,2*KFIELD) - divergence (input) ! PU(NLEI1,2*KFIELD) - u wind (output) ! PV(NLEI1,2*KFIELD) - v wind (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUV in IFS CY22R1 ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:,:),PDIV(:,:,:) REAL(KIND=JPRB), INTENT(OUT) :: PU (:,:,:),PV (:,:,:) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) REAL(KIND=JPRB), OPTIONAL, INTENT(IN) :: PSPMEANU(:),PSPMEANV(:) INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, IN, IFLD INTEGER(KIND=JPIM) :: JM, IM INTEGER(KIND=JPIM) :: JNMAX REAL(KIND=JPRB) :: ZLEPINM REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('EVDTUV_MOD:EVDTUV',0,ZHOOK_HANDLE) JNMAX = MAXVAL (DALD%NCPL2M) !$acc parallel loop collapse (3) private (JM, J, JN, IM, IN, ZIN) & !$acc & present (D%NUMP, D%MYMS, DALD%NCPL2M, PU, PV, PVOR, PDIV) DO J=1,2*KFIELD DO JM = 1, D%NUMP DO JN=1,JNMAX,2 IM = D%MYMS (JM) IF (JN <= DALD%NCPL2M(IM)) THEN IN = (JN-1)/2 ZIN = REAL(IN,JPRB)*GALD%EYWN PU(JN ,JM,J) = -ZIN*PVOR(JN+1,JM,J) PU(JN+1,JM,J) = ZIN*PVOR(JN ,JM,J) PV(JN ,JM,J) = -ZIN*PDIV(JN+1,JM,J) PV(JN+1,JM,J) = ZIN*PDIV(JN ,JM,J) ENDIF ENDDO ENDDO ENDDO !$acc end parallel loop !$acc parallel loop collapse (3) private (JM, J, JN, IM, ZKM, IR, II, IJ, ZLEPINM) & !$acc & present (D%NUMP, D%MYMS, DALD%NCPL2M, FALD%RLEPINM, PU, PV, PDIV, PVOR) DO J=1,KFIELD DO JM = 1, D%NUMP DO JN=1,JNMAX IM = D%MYMS (JM) ZKM=REAL(IM,JPRB)*GALD%EXWN IR = 2*J-1 II = IR+1 IF (JN <= DALD%NCPL2M(IM)) THEN IJ=(JN-1)/2 ZLEPINM = FALD%RLEPINM(DALD%NPME(IM)+IJ) PU(JN,JM,IR)= ZLEPINM*(-ZKM*PDIV(JN,JM,II)-PU(JN,JM,IR)) PU(JN,JM,II)= ZLEPINM*( ZKM*PDIV(JN,JM,IR)-PU(JN,JM,II)) PV(JN,JM,IR)= ZLEPINM*(-ZKM*PVOR(JN,JM,II)+PV(JN,JM,IR)) PV(JN,JM,II)= ZLEPINM*( ZKM*PVOR(JN,JM,IR)+PV(JN,JM,II)) ENDIF ENDDO ENDDO ENDDO !$acc end parallel loop IF (PRESENT(KFLDPTR)) THEN !$acc parallel loop collapse (2) private (J, JM, IM, IR, IFLD) & !$acc & present (D%NUMP, D%MYMS, PU, PV, PSPMEANU, PSPMEANV) copyin (KFLDPTR) DO J = 1, KFIELD DO JM = 1, D%NUMP IM = D%MYMS (JM) IF (IM == 0) THEN IR = 2*J-1 IFLD=KFLDPTR(J) PU(1,JM,IR)=PSPMEANU(IFLD) PV(1,JM,IR)=PSPMEANV(IFLD) ENDIF ENDDO ENDDO !$acc end parallel loop ELSE !$acc parallel loop collapse (2) private (J, JM, IM, IR) & !$acc & present (D%NUMP, D%MYMS, PU, PV, PSPMEANU, PSPMEANV) DO J = 1, KFIELD DO JM = 1, D%NUMP IM = D%MYMS (JM) IF (IM == 0) THEN IR = 2*J-1 PU(1,JM,IR)=PSPMEANU(J) PV(1,JM,IR)=PSPMEANV(J) ENDIF ENDDO ENDDO !$acc end parallel loop ENDIF IF (LHOOK) CALL DR_HOOK('EVDTUV_MOD:EVDTUV',1,ZHOOK_HANDLE) END SUBROUTINE EVDTUV END MODULE EVDTUV_MODectrans-1.8.0/src/etrans/gpu/internal/eltinv_mod.F900000664000175000017500000002336115174631767022503 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) MODULE ELTINV_MOD USE BUFFERED_ALLOCATOR_MOD IMPLICIT NONE PRIVATE PUBLIC :: ELTINV, ELTINV_HANDLE, PREPARE_ELTINV TYPE ELTINV_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFFT TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFFT_OUT TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF_IN !TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF END TYPE CONTAINS FUNCTION PREPARE_ELTINV(ALLOCATOR,KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT) RESULT(HELTINV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD USE TPM_DISTR, ONLY: D USE TPM_DIM, ONLY: R USE TPMALD_DIM ,ONLY : RALD USE ISO_C_BINDING IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) ::KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT TYPE(ELTINV_HANDLE) :: HELTINV INTEGER(KIND=C_SIZE_T) :: IALLOC_SZ REAL(KIND=JPRBT) :: ZPRBT_DUMMY ! ZFFT IALLOC_SZ = ALIGN((RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*(8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS)*SIZEOF(ZPRBT_DUMMY), 128) HELTINV%HFFT = RESERVE(ALLOCATOR, IALLOC_SZ) #ifndef IN_PLACE_FFT ! ZFFT IALLOC_SZ = ALIGN((RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*(8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS)*SIZEOF(ZPRBT_DUMMY), 128) HELTINV%HFFT_OUT = RESERVE(ALLOCATOR, IALLOC_SZ) #endif ! FOUBUF_IN IALLOC_SZ = D%NLENGT1B*2*KF_OUT_LT*SIZEOF(ZPRBT_DUMMY) HELTINV%HFOUBUF_IN = RESERVE(ALLOCATOR, IALLOC_SZ) END FUNCTION PREPARE_ELTINV SUBROUTINE ELTINV(ALLOCATOR,HELTINV,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,FOUBUF_IN,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) USE ISO_C_BINDING USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B USE TPMALD_DIM ,ONLY : RALD USE EPRFI1B_MOD ,ONLY : EPRFI1B USE EVDTUV_MOD ,ONLY : EVDTUV USE ESPNSDE_MOD ,ONLY : ESPNSDE USE ELEINV_MOD ,ONLY : ELEINV USE EASRE1B_MOD ,ONLY : EASRE1B !!! FIXME !!! USE FSPGL_INT_MOD ,ONLY : FSPGL_INT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !**** *LTINV* - Inverse Legendre transform ! Purpose. ! -------- ! Tranform from Laplace space to Fourier space, compute U and V ! and north/south derivatives of state variables. !** Interface. ! ---------- ! *CALL* *LTINV(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : The Laplace arrays of the model. ! -------------------- The values of the Legendre polynomials ! The grid point arrays of the model ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1B - prepares the spectral fields ! VDTUV - compute u and v from vorticity and divergence ! SPNSDE - compute north-south derivatives ! LEINV - Inverse Legendre transform ! ASRE1 - recombination of symmetric/antisymmetric part ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINV in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 26-Aug-2021 Optimization for EASRE1B ! ------------------------------------------------------------------ IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(ELTINV_HANDLE), INTENT(IN) :: HELTINV INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 INTEGER(KIND=JPIM), INTENT(IN) :: KDIM1 REAL(KIND=JPRB), INTENT(OUT), POINTER :: FOUBUF_IN(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB), POINTER :: ZFFT_L(:), ZFFT(:,:,:), ZFFT_L_OUT(:), ZFFT_OUT(:,:,:) INTEGER(KIND=JPIM) :: IFC, ISTA INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU INTEGER(KIND=JPIM) :: IFIRST, ILAST,IDIM1,IDIM3,J3 INTEGER(KIND=C_SIZE_T) :: IALLOC_SZ REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- IF (LHOOK) CALL DR_HOOK('ELTINV_MOD:ELTINV',0,ZHOOK_HANDLE) ! ZFFT IALLOC_SZ = ALIGN((RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*KLEI2*SIZEOF(ZFFT_L(1)), 128) CALL ASSIGN_PTR(ZFFT_L, GET_ALLOCATION(ALLOCATOR, HELTINV%HFFT),& & 1_JPIB, IALLOC_SZ) CALL C_F_POINTER(C_LOC(ZFFT_L), ZFFT, (/ RALD%NDGLSUR+R%NNOEXTZG,D%NUMP,KLEI2 /)) #ifdef OMPGPU #endif #ifdef ACCGPU !$ACC DATA COPYIN(PSPVOR,PSPDIV) IF(KF_UV > 0) !$ACC DATA COPYIN(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$ACC DATA COPYIN(PSPSC2) IF(PRESENT(PSPSC2)) !$ACC DATA COPYIN(PSPSC3A) IF(PRESENT(PSPSC3A)) !$ACC DATA COPYIN(PSPSC3B) IF(PRESENT(PSPSC3B)) !$ACC DATA COPYIN(PSPMEANU) IF(KF_UV > 0) !$ACC DATA COPYIN(PSPMEANV) IF(KF_UV > 0) #endif IFIRST = 1 ILAST = 4*KF_UV ! TODO: this zero-initialization is needed, but could be moved more efficiently inside EPRFI1B/EVDTUV/ESPNSDE !$acc kernels present (ZFFT) ZFFT = 0.0_JPRB !$acc end kernels IF (KF_UV > 0) THEN IVORL = 1 IVORU = 2*KF_UV IDIVL = 2*KF_UV+1 IDIVU = 4*KF_UV IUL = 4*KF_UV+1 IUU = 6*KF_UV IVL = 6*KF_UV+1 IVU = 8*KF_UV CALL EPRFI1B(ZFFT(:,:,IVORL:IVORU),PSPVOR,KF_UV,KFLDPTRUV) CALL EPRFI1B(ZFFT(:,:,IDIVL:IDIVU),PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV CALL EVDTUV(KF_UV,KFLDPTRUV,ZFFT(:,:,IVORL:IVORU),ZFFT(:,:,IDIVL:IDIVU),& & ZFFT(:,:,IUL:IUU),ZFFT(:,:,IVL:IVU),PSPMEANU,PSPMEANV) ENDIF IF(KF_SCALARS > 0)THEN IF(PRESENT(PSPSCALAR)) THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL EPRFI1B(ZFFT(:,:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IFIRST = ILAST+1 ILAST = IFIRST-1+2*NF_SC2 CALL EPRFI1B(ZFFT(:,:,IFIRST:ILAST),PSPSC2(:,:),NF_SC2) ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL EPRFI1B(ZFFT(:,:,IFIRST:ILAST),PSPSC3A(:,:,J3),IDIM1) ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL EPRFI1B(ZFFT(:,:,IFIRST:ILAST),PSPSC3B(:,:,J3),IDIM1) ENDDO ENDIF ENDIF IF(ILAST /= 8*KF_UV+2*KF_SCALARS) THEN WRITE(0,*) 'LTINV:KF_UV,KF_SCALARS,ILAST ',KF_UV,KF_SCALARS,ILAST CALL ABORT_TRANS('LTINV_MOD:ILAST /= 8*KF_UV+2*KF_SCALARS') ENDIF ENDIF IF (KF_SCDERS > 0) THEN ISL = 2*(4*KF_UV)+1 ISU = ISL+2*KF_SCALARS-1 IDL = 2*(4*KF_UV+KF_SCALARS)+1 IDU = IDL+2*KF_SCDERS-1 CALL ESPNSDE(KF_SCALARS,ZFFT(:,:,ISL:ISU),ZFFT(:,:,IDL:IDU)) ENDIF ! ------------------------------------------------------------------ !* 4. INVERSE LEGENDRE TRANSFORM. ! --------------------------- ISTA = 1 IFC = 2*KF_OUT_LT IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN ISTA = ISTA+2*KF_UV ENDIF IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN ISTA = ISTA+2*KF_UV ENDIF ! ZFFT_OUT #ifdef IN_PLACE_FFT ZFFT_OUT=>ZFFT #else IALLOC_SZ = ALIGN((RALD%NDGLSUR+R%NNOEXTZG)*D%NUMP*KLEI2*SIZEOF(ZFFT_L_OUT(1)), 128) CALL ASSIGN_PTR(ZFFT_L_OUT, GET_ALLOCATION(ALLOCATOR, HELTINV%HFFT_OUT),& & 1_JPIB, IALLOC_SZ) CALL C_F_POINTER(C_LOC(ZFFT_L_OUT), ZFFT_OUT, (/ RALD%NDGLSUR+R%NNOEXTZG,D%NUMP,KLEI2 /)) #endif CALL ELEINV(ALLOCATOR,ZFFT,ZFFT_OUT) ! ------------------------------------------------------------------ !* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. ! -------------------------------------------- ! FOUBUF_IN IALLOC_SZ = D%NLENGT1B*2*KF_OUT_LT*SIZEOF(FOUBUF_IN(1)) CALL ASSIGN_PTR(FOUBUF_IN, GET_ALLOCATION(ALLOCATOR, HELTINV%HFOUBUF_IN),& & 1_JPIB, IALLOC_SZ) CALL EASRE1B(KF_OUT_LT,ZFFT_OUT(:,:,ISTA:ISTA+IFC-1),FOUBUF_IN) ! ------------------------------------------------------------------ ! 6. OPTIONAL COMPUTATIONS IN FOURIER SPACE IF(PRESENT(FSPGL_PROC)) THEN !!! FIXME !!! CALL FSPGL_INT(KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT,FSPGL_PROC,& !!! FIXME !!! & KFLDPTRUV,KFLDPTRSC) CALL ABORT('FIXME') ENDIF #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('ELTINV_MOD:ELTINV',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTINV END MODULE ELTINV_MOD ectrans-1.8.0/src/etrans/gpu/internal/eleinv_mod.F900000664000175000017500000000602215174631767022457 0ustar alastairalastairMODULE ELEINV_MOD CONTAINS SUBROUTINE ELEINV(ALLOCATOR,PFFT,PFFT_OUT) !**** *LEINV* - Inverse Legendre transform. ! Purpose. ! -------- ! Inverse Legendre tranform of all variables(kernel). !** Interface. ! ---------- ! CALL LEINV(...) ! Explicit arguments : KM - zonal wavenumber (input-c) ! -------------------- KFC - number of fields to tranform (input-c) ! PIA - spectral fields ! for zonal wavenumber KM (input) ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PLEPO - Legendre polonomials for zonal ! wavenumber KM (input-c) ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - calls SGEMVX (matrix multiply) ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LEINV in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 01-Sep-2015 support for FFTW transforms ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB, JPIB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN, ONLY : NCUR_RESOL USE TPM_DISTR ,ONLY : D USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_HICFFT ,ONLY : EXECUTE_INV_FFT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE ISO_C_BINDING USE BUFFERED_ALLOCATOR_MOD IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR REAL(KIND=JPRB), INTENT(INOUT) :: PFFT(:,:,:), PFFT_OUT(:,:,:) INTEGER(KIND=JPIM) :: JLOT REAL (KIND=JPRB), POINTER :: ZFFT_L(:), ZFFT_L_OUT(:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',0,ZHOOK_HANDLE) JLOT=UBOUND(PFFT,2)*UBOUND (PFFT,3) CALL C_F_POINTER(C_LOC(PFFT), ZFFT_L, (/UBOUND(PFFT,1)*UBOUND(PFFT,2)*UBOUND(PFFT,3)/) ) CALL C_F_POINTER(C_LOC(PFFT_OUT), ZFFT_L_OUT, (/UBOUND(PFFT_OUT,1)*UBOUND(PFFT_OUT,2)*UBOUND(PFFT_OUT,3)/) ) IF (JLOT==0) THEN IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',1,ZHOOK_HANDLE) RETURN ENDIF !$ACC DATA PRESENT(ZFFT_L,ZFFT_L_OUT,RALD%NLOENS_LAT,RALD%NOFFSETS_LAT) CALL EXECUTE_INV_FFT(ZFFT_L,ZFFT_L_OUT,NCUR_RESOL,-JLOT, & & RALD%NLOENS_LAT, & & RALD%NOFFSETS_LAT,ALLOCATOR%PTR) !$ACC END DATA IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',1,ZHOOK_HANDLE) END SUBROUTINE ELEINV END MODULE ELEINV_MODectrans-1.8.0/src/etrans/gpu/internal/edealloc_resol_mod.F900000664000175000017500000000515015174631767024152 0ustar alastairalastairMODULE EDEALLOC_RESOL_MOD CONTAINS SUBROUTINE EDEALLOC_RESOL(KRESOL) !**** *EDEALLOC_RESOL_MOD* - Deallocations of a resolution ! Purpose. ! -------- ! Release allocated arrays for a given resolution !** Interface. ! ---------- ! CALL EDEALLOC_RESOL_MOD ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 from etrans_end ! B. Bochenek (Apr 2015): Phasing: update ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : LENABLED, NOUT USE TPM_DISTR ,ONLY : D USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F USE TPM_DIM ,ONLY : R USE TPMALD_DISTR ,ONLY : DALD USE TPMALD_DIM ,ONLY : RALD USE TPMALD_FIELDS ,ONLY : FALD USE TPM_HICFFT, ONLY: CLEAN_FFT USE ESET_RESOL_MOD ,ONLY : ESET_RESOL IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KRESOL ! ------------------------------------------------------------------ IF (.NOT.LENABLED(KRESOL)) THEN WRITE(UNIT=NOUT,FMT='('' EDEALLOC_RESOL WARNING: KRESOL = '',I3,'' ALREADY DISABLED '')') KRESOL ELSE CALL ESET_RESOL(KRESOL) !$ACC EXIT DATA DELETE(R%NSMAX,R%NTMAX,R%NDGL,R%NDGNH,D%NSTAGT0B,D%NSTAGT1B,& !$ACC& D%NPNTGTB1,D%NPROCL,D%NUMP,D%NDGL_FS,D%MYMS,D%NASM0,D%NSTAGTF,D%MSTABF,& !$ACC& D%NPNTGTB0,D%NPROCM,D%NPTRLS,G%NDGLU,G%NMEN,G%NLOEN,& !$ACC& DALD%NESM0,DALD%NCPL2M, DALD%NPME, FALD%RLEPINM, & !$ACC& RALD%NLOENS_LON,RALD%NOFFSETS_LON,RALD%NLOENS_LAT,RALD%NOFFSETS_LAT) !$ACC EXIT DATA DELETE(R,D,G,DALD,FALD,RALD) CALL CLEAN_FFT(KRESOL) !TPM_DISTR DEALLOCATE(D%NFRSTLAT,D%NLSTLAT,D%NPTRLAT,D%NPTRFRSTLAT,D%NPTRLSTLAT) DEALLOCATE(D%LSPLITLAT,D%NSTA,D%NONL,D%NGPTOTL,D%NPROCA_GP) IF(D%LWEIGHTED_DISTR) THEN DEALLOCATE(D%RWEIGHT) ENDIF IF(.NOT.D%LGRIDONLY) THEN DEALLOCATE(D%MYMS,D%NUMPP,D%NPOSSP,D%NPROCM,D%NDIM0G,D%NASM0,D%NATM0) DEALLOCATE(D%NLATLS,D%NLATLE,D%NPMT,D%NPMS,D%NPMG,D%NULTPP,D%NPROCL) DEALLOCATE(D%NPTRLS,D%NALLMS,D%NPTRMS,D%NSTAGT0B,D%NSTAGT1B,D%NPNTGTB0) DEALLOCATE(D%NPNTGTB1,D%NLTSFTB,D%NLTSGTB,D%MSTABF) DEALLOCATE(D%NSTAGTF) DEALLOCATE(G%NMEN,G%NDGLU) ELSE DEALLOCATE(G%NLOEN) ENDIF LENABLED(KRESOL)=.FALSE. ENDIF ! ------------------------------------------------------------------ END SUBROUTINE EDEALLOC_RESOL END MODULE EDEALLOC_RESOL_MOD ectrans-1.8.0/src/etrans/gpu/internal/eset_resol_mod.F900000664000175000017500000000336715174631767023352 0ustar alastairalastairMODULE ESET_RESOL_MOD CONTAINS SUBROUTINE ESET_RESOL(KRESOL) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, MSETUP0, NCUR_RESOL, NMAX_RESOL USE TPM_DIM ,ONLY : R, DIM_RESOL !USE TPM_TRANS USE TPM_DISTR ,ONLY : D, DISTR_RESOL USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL USE TPM_CTL, ONLY : C, CTL_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL USE TPMALD_DISTR ,ONLY : DALD, ALDDISTR_RESOL USE TPMALD_FIELDS ,ONLY : FALD, ALDFIELDS_RESOL USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL ! Local varaibles INTEGER(KIND=JPIM) :: IRESOL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESET_RESOL_MOD:ESET_RESOL',0,ZHOOK_HANDLE) IF(MSETUP0 == 0) CALL ABORT_TRANS('ESET_RESOL:TRANS NOT SETUP') IRESOL = 1 IF(PRESENT(KRESOL)) THEN IRESOL = KRESOL IF(KRESOL < 1 .OR. KRESOL > NMAX_RESOL) THEN WRITE(NOUT,*)'ESET_RESOL: UNKNOWN RESOLUTION ',KRESOL,NMAX_RESOL CALL ABORT_TRANS('ESET_RESOL:KRESOL < 1 .OR. KRESOL > NMAX_RESOL') ENDIF ENDIF IF(IRESOL /= NCUR_RESOL) THEN NCUR_RESOL = IRESOL R => DIM_RESOL(NCUR_RESOL) F => FIELDS_RESOL(NCUR_RESOL) G => GEOM_RESOL(NCUR_RESOL) D => DISTR_RESOL(NCUR_RESOL) C => CTL_RESOL(NCUR_RESOL) RALD => ALDDIM_RESOL(NCUR_RESOL) DALD => ALDDISTR_RESOL(NCUR_RESOL) FALD => ALDFIELDS_RESOL(NCUR_RESOL) GALD => ALDGEO_RESOL(NCUR_RESOL) ENDIF IF (LHOOK) CALL DR_HOOK('ESET_RESOL_MOD:ESET_RESOL',1,ZHOOK_HANDLE) END SUBROUTINE ESET_RESOL END MODULE ESET_RESOL_MOD ectrans-1.8.0/src/etrans/gpu/internal/suemp_trans_preleg_mod.F900000664000175000017500000001466315174631767025105 0ustar alastairalastairMODULE SUEMP_TRANS_PRELEG_MOD CONTAINS SUBROUTINE SUEMP_TRANS_PRELEG ! Set up distributed environment for the transform package (part 1) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRW, NPRTRV, MYSETW USE TPMALD_DISTR ,ONLY : DALD USE TPMALD_DIM ,ONLY : RALD USE TPMALD_FIELDS ,ONLY : FALD USE TPMALD_GEO ,ONLY : GALD !USE SUWAVEDI_MOD !USE ABORT_TRANS_MOD IMPLICIT NONE INTEGER(KIND=JPIM) :: JA,JM,JMLOC,JW,JV,ILATPP,IRESTL,IMLOC,IDT,INM,JN,IM,ILAST LOGICAL :: LLP1,LLP2 INTEGER(KIND=JPIM) :: ISPEC(NPRTRW),IMYMS(RALD%NMSMAX+1),IKNTMP(0:RALD%NMSMAX) INTEGER(KIND=JPIM) :: IKMTMP(0:R%NSMAX),ISPEC2P INTEGER(KIND=JPIM) :: IC(NPRTRW) INTEGER(KIND=JPIM) :: IMDIM,IL,IND,IK,IPOS,IKM REAL(KIND=JPRB) :: ZLEPDIM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_PRELEG_MOD:SUEMP_TRANS_PRELEG',0,ZHOOK_HANDLE) IF(.NOT.D%LGRIDONLY) THEN LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEMP_TRANS_PRELEG ===' !* 1. Initialize partitioning of wave numbers to PEs ! ! ---------------------------------------------- ALLOCATE(D%NASM0(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NASM0 ',SIZE(D%NASM0 ),SHAPE(D%NASM0 ) ALLOCATE(DALD%NESM0(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'DALD%NESM0 ',SIZE(DALD%NESM0 ),SHAPE(DALD%NESM0 ) ALLOCATE(D%NATM0(0:R%NTMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NATM0 ',SIZE(D%NATM0 ),SHAPE(D%NATM0 ) ALLOCATE(D%NUMPP(NPRTRW)) IF(LLP2)WRITE(NOUT,9) 'D%NUMPP ',SIZE(D%NUMPP ),SHAPE(D%NUMPP ) ALLOCATE(D%NPOSSP(NPRTRW+1)) IF(LLP2)WRITE(NOUT,9) 'D%NPOSSP',SIZE(D%NPOSSP ),SHAPE(D%NPOSSP ) ALLOCATE(D%NPROCM(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCM',SIZE(D%NPROCM ),SHAPE(D%NPROCM ) ALLOCATE(DALD%NPME(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'DALD%NPME',SIZE(DALD%NPME),SHAPE(DALD%NPME) ALLOCATE(DALD%NCPL2M(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'DALD%NCPL2M',SIZE(DALD%NCPL2M),SHAPE(DALD%NCPL2M) CALL ELLIPS(R%NSMAX,RALD%NMSMAX,IKNTMP,IKMTMP) DALD%NPME(0)=1 DO JM=1,RALD%NMSMAX DALD%NPME(JM)=DALD%NPME(JM-1)+IKNTMP(JM-1)+1 ENDDO DO JM=0,RALD%NMSMAX DALD%NCPL2M(JM) = 2*(IKNTMP(JM)+1) ENDDO ALLOCATE(FALD%RLEPINM(R%NSPEC_G/2)) IF(LLP2)WRITE(NOUT,9) 'FALD%RLEPINM',SIZE(FALD%RLEPINM),SHAPE(FALD%RLEPINM) DO JM=0,RALD%NMSMAX DO JN=1,IKNTMP(JM) ZLEPDIM=-((REAL(JM,JPRB)**2)*(GALD%EXWN**2)+& & (REAL(JN,JPRB)**2)*(GALD%EYWN**2)) FALD%RLEPINM(DALD%NPME(JM)+JN)=1./ZLEPDIM ENDDO ENDDO DO JM=1,RALD%NMSMAX ZLEPDIM=-(REAL(JM,JPRB)**2)*(GALD%EXWN**2) FALD%RLEPINM(DALD%NPME(JM))=1./ZLEPDIM ENDDO FALD%RLEPINM(DALD%NPME(0))=0. D%NUMPP(:) = 0 ISPEC(:) = 0 DALD%NESM0(:)=-99 IMDIM = 0 IL = 1 IND = 1 IK = 0 IPOS = 1 DO JM=0,RALD%NMSMAX IK = IK + IND IF (IK > NPRTRW) THEN IK = NPRTRW IND = -1 ELSEIF (IK < 1) THEN IK = 1 IND = 1 ENDIF IKM =DALD%NCPL2M(JM)/2 -1 D%NPROCM(JM) = IK ISPEC(IK) = ISPEC(IK)+IKM+1 D%NUMPP(IK) = D%NUMPP(IK)+1 IF (IK == MYSETW) THEN IMDIM = IMDIM + IKM+1 IMYMS(IL) = JM DALD%NESM0(JM) = IPOS IPOS = IPOS+(IKM+1)*4 IL = IL+1 ENDIF ENDDO D%NPOSSP(1) = 1 ISPEC2P = 4*ISPEC(1) D%NSPEC2MX = ISPEC2P DO JA=2,NPRTRW D%NPOSSP(JA) = D%NPOSSP(JA-1)+ISPEC2P ISPEC2P = 4*ISPEC(JA) D%NSPEC2MX=MAX(D%NSPEC2MX,ISPEC2P) ENDDO D%NPOSSP(NPRTRW+1) = D%NPOSSP(NPRTRW)+ISPEC2P D%NSPEC2 = 4*IMDIM D%NSPEC=D%NSPEC2 D%NUMP = D%NUMPP (MYSETW) ALLOCATE(D%MYMS(D%NUMP)) IF(LLP2)WRITE(NOUT,9) 'D%MYMS ',SIZE(D%MYMS ),SHAPE(D%MYMS ) D%MYMS(:) = IMYMS(1:D%NUMP) D%NUMTP = D%NUMP ! pointer to the first wave number of a given wave-set in NALLMS array ALLOCATE(D%NPTRMS(NPRTRW)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRMS ',SIZE(D%NPTRMS ),SHAPE(D%NPTRMS ) D%NPTRMS(:) = 1 DO JA=2,NPRTRW D%NPTRMS(JA) = D%NPTRMS(JA-1)+D%NUMPP(JA-1) ENDDO ! D%NALLMS : wave numbers for all wave-set concatenated together to give all ! wave numbers in wave-set order. ALLOCATE(D%NALLMS(RALD%NMSMAX+1)) IF(LLP2)WRITE(NOUT,9) 'D%NALLMS ',SIZE(D%NALLMS ),SHAPE(D%NALLMS ) IC(:) = 0 DO JM=0,RALD%NMSMAX D%NALLMS(IC(D%NPROCM(JM))+D%NPTRMS(D%NPROCM(JM))) = JM IC(D%NPROCM(JM)) = IC(D%NPROCM(JM))+1 ENDDO ALLOCATE(D%NDIM0G(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NDIM0G ',SIZE(D%NDIM0G ),SHAPE(D%NDIM0G ) IPOS = 1 DO JA=1,NPRTRW DO JMLOC=1,D%NUMPP(JA) IM = D%NALLMS(D%NPTRMS(JA)+JMLOC-1) D%NDIM0G(IM) = IPOS IPOS = IPOS+2*DALD%NCPL2M(IM) ENDDO ENDDO ALLOCATE(D%NLATLS(NPRTRW,NPRTRV)) IF(LLP2)WRITE(NOUT,9) 'D%NLATLS',SIZE(D%NLATLS ),SHAPE(D%NLATLS ) ALLOCATE(D%NLATLE(NPRTRW,NPRTRV)) IF(LLP2)WRITE(NOUT,9) 'D%NLATLE',SIZE(D%NLATLE ),SHAPE(D%NLATLE ) D%NLATLS(:,:) = 9999 D%NLATLE(:,:) = -1 ILATPP = R%NDGL/NPRTRW IRESTL = R%NDGL-NPRTRW*ILATPP DO JW=1,NPRTRW IF (JW > IRESTL) THEN D%NLATLS(JW,1) = IRESTL*(ILATPP+1)+(JA-IRESTL-1)*ILATPP+1 D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP-1 ELSE D%NLATLS(JW,1) = (JA-1)*(ILATPP+1)+1 D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP ENDIF ENDDO ILAST=0 DO JW=1,NPRTRW ILATPP = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)/NPRTRV IRESTL = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)-NPRTRV*ILATPP DO JV=1,NPRTRV IF (JV > IRESTL) THEN D%NLATLS(JW,JV) = IRESTL*(ILATPP+1)+(JV-IRESTL-1)*ILATPP+1+ILAST D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP-1 ELSE D%NLATLS(JW,JV) = (JV-1)*(ILATPP+1)+1+ILAST D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP ENDIF ENDDO ILAST=D%NLATLE(JW,NPRTRV) ENDDO IF (LLP1) THEN DO JW=1,NPRTRW DO JV=1,NPRTRV WRITE(NOUT,'(" JW=",I6," JV=",I6," D%NLATLS=",I6," D%NLATLE=",I6)')& & JW,JV,D%NLATLS(JW,JV),D%NLATLE(JW,JV) ENDDO ENDDO ENDIF ALLOCATE(D%NPMT(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMT ',SIZE(D%NPMT ),SHAPE(D%NPMT ) ALLOCATE(D%NPMS(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMS ',SIZE(D%NPMS ),SHAPE(D%NPMS ) ALLOCATE(D%NPMG(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMG ',SIZE(D%NPMG ),SHAPE(D%NPMG ) IDT = R%NTMAX-R%NSMAX INM = 0 DO JMLOC=1,D%NUMP IMLOC = D%MYMS(JMLOC) INM = INM+R%NTMAX+2-IMLOC ENDDO INM = 0 DO JM=0,R%NSMAX INM = INM+R%NTMAX+2-JM ENDDO D%NLEI3D = (R%NLEI3-1)/NPRTRW+1 ENDIF IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_PRELEG_MOD:SUEMP_TRANS_PRELEG',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUEMP_TRANS_PRELEG END MODULE SUEMP_TRANS_PRELEG_MOD ectrans-1.8.0/src/etrans/gpu/internal/egath_spec_control_mod.F900000664000175000017500000001326115174631767025042 0ustar alastairalastairMODULE EGATH_SPEC_CONTROL_MOD CONTAINS SUBROUTINE EGATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& & KSMAX,KSPEC2,KSPEC2_G,KPOSSP,KDIM0G,KCPL2M,LDZA0IP) !**** *GATH_SPEC_CONTROL* - Gather global spectral array from processors ! Purpose. ! -------- ! Routine for gathering spectral array !** Interface. ! ---------- ! CALL GATH_SPEC_CONTROL(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be distributed ! KTO(:) - Processor responsible for distributing each field ! KVSET(:) - "B-Set" for each field ! PSPEC(:,:) - Local spectral array ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : MTAGDISTSP, NPRCIDS, NPRTRW, MYSETV, MYPROC, NPROC USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE SET2PE_MOD ,ONLY : SET2PE IMPLICIT NONE REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2_G INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) INTEGER(KIND=JPIM) , INTENT(IN) :: KCPL2M(0:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP REAL(KIND=JPRB) :: ZFLD(KSPEC2,KFGATHG) REAL(KIND=JPRB),ALLOCATABLE :: ZRECV(:,:) INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,IBSET,ILEN,JA,ISND INTEGER(KIND=JPIM) :: IRCV,ILENR,ISTA,ISTP,ISENDREQ(KFGATHG),JNM INTEGER(KIND=JPIM) :: IDIST(KSPEC2_G),IMYFIELDS ! ------------------------------------------------------------------ CALL ABORT_TRANS('EGATH_SPEC_CONTROL:DEAD CODE') !GATHER SPECTRAL ARRAY IF( NPROC == 1 ) THEN CALL GSTATS(1644,0) IF(LDIM1_IS_FLD) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) DO JM=1,KSPEC2_G DO JFLD=1,KFGATHG PSPECG(JFLD,JM) =PSPEC(JFLD,JM) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) DO JFLD=1,KFGATHG DO JM=1,KSPEC2_G PSPECG(JM,JFLD) =PSPEC(JM,JFLD) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1644,1) ELSE IMYFIELDS = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO IF(IMYFIELDS>0) THEN ALLOCATE(ZRECV(KSPEC2_G,IMYFIELDS)) II = 0 CALL GSTATS(1804,0) DO JM=0,KSMAX DO JN=0,KCPL2M(JM)/2-1 IDIST(II+1) = KDIM0G(JM)+4*JN IDIST(II+2) = KDIM0G(JM)+4*JN+1 IDIST(II+3) = KDIM0G(JM)+4*JN+2 IDIST(II+4) = KDIM0G(JM)+4*JN+3 II = II+4 ENDDO ENDDO CALL GSTATS(1804,1) ENDIF CALL GSTATS_BARRIER(788) !Send CALL GSTATS(810,0) IFLDS = 0 IF(KSPEC2 > 0 )THEN DO JFLD=1,KFGATHG IBSET = KVSET(JFLD) IF( IBSET == MYSETV )THEN IFLDS = IFLDS+1 ISND = KTO(JFLD) ITAG = MTAGDISTSP+JFLD+17 IF(LDIM1_IS_FLD) THEN ZFLD(1:KSPEC2,IFLDS)=PSPEC(IFLDS,1:KSPEC2) CALL MPL_SEND(ZFLD(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& &CDSTRING='GATH_SPEC_CONTROL') ELSE CALL MPL_SEND(PSPEC(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& &CDSTRING='GATH_SPEC_CONTROL') ENDIF ENDIF ENDDO ENDIF ! Recieve IFLDR = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IBSET = KVSET(JFLD) IFLDR = IFLDR+1 DO JA=1,NPRTRW ILEN = KPOSSP(JA+1)-KPOSSP(JA) IF( ILEN > 0 )THEN CALL SET2PE(IRCV,0,0,JA,IBSET) ITAG = MTAGDISTSP+JFLD+17 ISTA = KPOSSP(JA) ISTP = ISTA+ILEN-1 CALL MPL_RECV(ZRECV(ISTA:ISTP,IFLDR),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & &CDSTRING='GATH_SPEC_CONTROL') IF( ILENR /= ILEN )THEN WRITE(0,'("GATH_SPEC_CONTROL: JFLD=",I4," JA=",I4," ILEN=",I10," ILENR=",I10)')& &JFLD,JA,ILEN,ILENR CALL ABORT_TRANS('GATH_SPEC_CONTROL:INVALID RECEIVE MESSAGE LENGTH') ENDIF ENDIF ENDDO ENDIF ENDDO ! Check for completion of sends IF(KSPEC2 > 0 )THEN DO JFLD=1,KFGATHG IBSET = KVSET(JFLD) IF( IBSET == MYSETV )THEN CALL MPL_WAIT(ISENDREQ(JFLD), & & CDSTRING='GATH_GRID_CTL: WAIT') ENDIF ENDDO ENDIF CALL GSTATS(810,1) CALL GSTATS_BARRIER2(788) CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JNM,II,JN) DO JFLD=1,IMYFIELDS IF(LDIM1_IS_FLD) THEN DO JNM=1,KSPEC2_G PSPECG(JFLD,JNM) = ZRECV(IDIST(JNM),JFLD) ENDDO ELSE DO JNM=1,KSPEC2_G PSPECG(JNM,JFLD) = ZRECV(IDIST(JNM),JFLD) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) IF(ALLOCATED(ZRECV)) DEALLOCATE(ZRECV) !Synchronize processors CALL GSTATS(785,0) CALL MPL_BARRIER(CDSTRING='GATH_SPEC_CONTROL:') CALL GSTATS(785,1) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE EGATH_SPEC_CONTROL END MODULE EGATH_SPEC_CONTROL_MOD ectrans-1.8.0/src/etrans/gpu/internal/eftdir_mod.F900000664000175000017500000000436215174631767022457 0ustar alastairalastairMODULE EFTDIR_MOD CONTAINS SUBROUTINE EFTDIR(ALLOCATOR,HFTDIR,PREEL,PREEL_COMPLEX,KF_FS,AUX_PROC) USE PARKIND1 ,ONLY : JPIM, JPRB, JPIB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN, ONLY: NCUR_RESOL USE TPM_DISTR ,ONLY : D USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_HICFFT ,ONLY : EXECUTE_DIR_FFT USE FTDIR_MOD, ONLY : FTDIR_HANDLE USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE ISO_C_BINDING USE BUFFERED_ALLOCATOR_MOD ! IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(FTDIR_HANDLE) :: HFTDIR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS REAL(KIND=JPRB), INTENT(INOUT), POINTER :: PREEL(:) ! (IRLEN+2)*NDGLG*KF_FS REAL(KIND=JPRB), INTENT(OUT), POINTER :: PREEL_COMPLEX(:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC INTEGER(KIND=JPIM) :: JLOT, IRLEN REAL(KIND=JPRB) :: ZDUM INTEGER(KIND=JPIM) :: INUL REAL(KIND=JPRB), POINTER, SAVE :: ZREEL(:), ZREEL_COMPLEX(:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',0,ZHOOK_HANDLE) IRLEN=R%NDLON+R%NNOEXTZG #ifdef IN_PLACE_FFT PREEL_COMPLEX => PREEL #else CALL ASSIGN_PTR(PREEL_COMPLEX, GET_ALLOCATION(ALLOCATOR, HFTDIR%HREEL_COMPLEX),& & 1_JPIB, 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(PREEL_COMPLEX(1))) #endif ! Periodization of auxiliary fields in x direction IF(R%NNOEXTZL>0) THEN !!! FIXME !!! CALL EXTPER(PREEL,R%NDLON+R%NNOEXTZL,1,R%NDLON,KF_FS,D%NDGL_FS,D%NSTAGTF,0) CALL ABORT('FIXME') ENDIF IF (PRESENT(AUX_PROC)) THEN !!! FIXME !!! CALL AUX_PROC(PREEL,ZDUM,KF_FS,D%NLENGTF,1,D%NDGL_FS,0,.TRUE.,& !!! FIXME !!! & D%NSTAGTF,INUL,INUL,INUL) CALL ABORT('FIXME') ENDIF JLOT=SIZE(PREEL)/(IRLEN+2) IF (JLOT==0) THEN IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',1,ZHOOK_HANDLE) RETURN ENDIF !$ACC DATA PRESENT(PREEL,RALD%NLOENS_LON,RALD%NOFFSETS_LON) CALL EXECUTE_DIR_FFT(PREEL,PREEL_COMPLEX,NCUR_RESOL,JLOT, & & LOENS=RALD%NLOENS_LON, & & OFFSETS=RALD%NOFFSETS_LON,ALLOC=ALLOCATOR%PTR) !$ACC END DATA IF (LHOOK) CALL DR_HOOK('EFTDIR_MOD:EFTDIR',1,ZHOOK_HANDLE) END SUBROUTINE EFTDIR END MODULE EFTDIR_MODectrans-1.8.0/src/etrans/gpu/internal/euvtvd_comm_mod.F900000664000175000017500000001160615174631767023531 0ustar alastairalastairMODULE EUVTVD_COMM_MOD CONTAINS SUBROUTINE EUVTVD_COMM(KM,KMLOC,KFIELD,KFLDPTR,PU,PV,PSPMEANU,PSPMEANV) !**** *EUVTVD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX - communication part. !** Interface. ! ---------- ! CALL EUVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number ! -------------------- KFIELD - number of fields (levels) ! KFLDPTR - fields pointers ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! 03-03-03 : G. Radnoti: b-level conform mean-wind distribution ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM USE TPM_FIELDS USE TPM_DISTR USE TPMALD_GEO USE TPMALD_DISTR USE MPL_MODULE USE SET2PE_MOD USE ABORT_TRANS_MOD IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD, KM, KMLOC REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:,:),PV (:,:,:) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) REAL(KIND=JPRB), OPTIONAL, INTENT(OUT) :: PSPMEANU(:),PSPMEANV(:) INTEGER(KIND=JPIM) :: IR, J INTEGER(KIND=JPIM) :: ISENDREQ(NPRTRW) REAL(KIND=JPRB) :: ZSPU(2*KFIELD) INTEGER(KIND=JPIM) :: JA,ITAG,ILEN,IFLD,ISND REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EUVTVD_COMM_MOD:EUVTVD_COMM',0,ZHOOK_HANDLE) !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ IF (KM == 0) THEN !$acc data present(PU,PV) !$acc data copyout (PSPMEANU, PSPMEANV) copyin(KMLOC) !$acc data copyin (KFLDPTR) if(present (KFLDPTR)) IF (PRESENT(KFLDPTR)) THEN !$acc parallel loop private(ir,ifld) DO J = 1, KFIELD IR = 2*J-1 IFLD=KFLDPTR(J) PSPMEANU(IFLD)=PU(1,KMLOC,IR) PSPMEANV(IFLD)=PV(1,KMLOC,IR) ENDDO !$acc end parallel loop ELSE !$acc parallel loop private(j,ir) DO J = 1, KFIELD IR = 2*J-1 PSPMEANU(J)=PU(1,KMLOC,IR) PSPMEANV(J)=PV(1,KMLOC,IR) ENDDO !$acc end parallel loop ENDIF !$acc end data !$acc end data !$acc end data ENDIF IF (NPRTRW > 1 .AND. KFIELD > 0) THEN IF (KM == 0) THEN IF (PRESENT(KFLDPTR)) THEN DO J=1,KFIELD IFLD=KFLDPTR(J) ZSPU(J)=PSPMEANU(IFLD) ZSPU(KFIELD+J)=PSPMEANV(IFLD) ENDDO ELSE DO J=1,KFIELD ZSPU(J)=PSPMEANU(J) ZSPU(KFIELD+J)=PSPMEANV(J) ENDDO ENDIF DO JA=1,NPRTRW IF (JA /= MYSETW) THEN CALL SET2PE(ISND,0,0,JA,MYSETV) ISND=NPRCIDS(ISND) ITAG=300000+KFIELD*NPROC+ISND CALL MPL_SEND(ZSPU(1:2*KFIELD),KDEST=ISND,KTAG=ITAG, & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JA),CDSTRING='EUVTVD_COMM:') ENDIF ENDDO ELSE IF (KMLOC == 1) THEN IF (D%NPROCM(0) /= MYSETW) THEN CALL SET2PE(ISND,0,0,D%NPROCM(0),MYSETV) ISND=NPRCIDS(ISND) ITAG=300000+KFIELD*NPROC+MYPROC CALL MPL_RECV(ZSPU(1:2*KFIELD),KSOURCE=ISND,KTAG=ITAG,KOUNT=ILEN, & & CDSTRING='EUVTVD_COMM:') IF (ILEN /= 2*KFIELD) CALL ABORT_TRANS('EUVTVD_COMM: RECV INVALID RECEIVE MESSAGE LENGHT') IF (PRESENT(KFLDPTR)) THEN DO J=1,KFIELD IFLD=KFLDPTR(J) PSPMEANU(IFLD)=ZSPU(J) PSPMEANV(IFLD)=ZSPU(KFIELD+J) ENDDO ELSE DO J=1,KFIELD PSPMEANU(J)=ZSPU(J) PSPMEANV(J)=ZSPU(KFIELD+J) ENDDO ENDIF ENDIF ENDIF ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('EUVTVD_COMM_MOD:EUVTVD_COMM',1,ZHOOK_HANDLE) END SUBROUTINE EUVTVD_COMM END MODULE EUVTVD_COMM_MODectrans-1.8.0/src/etrans/gpu/internal/tpmald_geo.F900000664000175000017500000000057415174631767022457 0ustar alastairalastairMODULE TPMALD_GEO ! Module containing data describing plane projection grid. USE PARKIND1 ,ONLY : JPRB IMPLICIT NONE SAVE TYPE ALDGEO_TYPE ! GEOGRAPHY REAL(KIND=JPRB) :: EYWN ! Y-reso REAL(KIND=JPRB) :: EXWN ! X-reso END TYPE ALDGEO_TYPE TYPE(ALDGEO_TYPE),ALLOCATABLE,TARGET :: ALDGEO_RESOL(:) TYPE(ALDGEO_TYPE),POINTER :: GALD END MODULE TPMALD_GEO ectrans-1.8.0/src/etrans/gpu/internal/efsc_mod.F900000664000175000017500000001224215174631767022116 0ustar alastairalastairMODULE EFSC_MOD CONTAINS SUBROUTINE EFSC(PREEL,KF_UV,KF_SCALARS,KF_SCDERS,KF_FS) !SUBROUTINE EFSC(KF_UV,KF_SCALARS,KF_SCDERS,& ! & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) !**** *FSC - Division by a*cos(theta), east-west derivatives ! Purpose. ! -------- ! In Fourier space divide u and v and all north-south ! derivatives by a*cos(theta). Also compute east-west derivatives ! of u,v,thermodynamic, passiv scalar variables and surface ! pressure. !** Interface. ! ---------- ! CALL FSC(..) ! Explicit arguments : PUV - u and v ! -------------------- PSCALAR - scalar valued varaibles ! PNSDERS - N-S derivative of S.V.V. ! PEWDERS - E-W derivative of S.V.V. ! PUVDERS - E-W derivative of u and v ! Method. ! ------- ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 (From SC2FSC) ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_TRANS ,ONLY : LUVDER, LVORGP, LDIVGP USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TPMALD_GEO ,ONLY : GALD ! IMPLICIT NONE REAL(KIND=JPRB) , INTENT(INOUT) :: PREEL(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KF_UV,KF_SCALARS,KF_SCDERS, KF_FS INTEGER(KIND=JPIM) :: JLOEN_MAX INTEGER(KIND=JPIM) :: JF,IGLG,JM,JGL REAL(KIND=JPRB) :: ZIM INTEGER(KIND=JPIM) :: I_UV_OFFSET, I_SC_OFFSET, I_SCDERS_OFFSET, I_UVDERS_OFFSET, IST INTEGER(KIND=JPIM) :: IOFF_LAT,IOFF_UV,IOFF_UV_EWDER, IOFF_SCALARS, IOFF_SCALARS_EWDER REAL(KIND=JPRB) :: RET_REAL, RET_COMPLEX REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EFSC_MOD:EFSC',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN IST = 0 IF(LVORGP) THEN IST = IST+KF_UV ENDIF IF(LDIVGP) THEN IST = IST+KF_UV ENDIF I_UV_OFFSET=IST IST = IST+2*KF_UV I_SC_OFFSET=IST IST = IST+KF_SCALARS !I_NSDERS_OFFSET=IST IST = IST+KF_SCDERS IF(LUVDER) THEN I_UVDERS_OFFSET=IST IST = IST+2*KF_UV ENDIF IF(KF_SCDERS > 0) THEN I_SCDERS_OFFSET=IST ENDIF ENDIF #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(D%NPTRLS,D%NSTAGTF,PREEL,G%NMEN, D) #endif ! ------------------------------------------------------------------ !* 2. EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. JLOEN_MAX=MAXVAL(G%NMEN) IF (LUVDER) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) SHARED(KF_UVPREEL) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IGLG,IOFF_LAT,IOFF_UV,IOFF_UV_EWDER,ZIM,RET_REAL,RET_COMPLEX,JM,JF,JGL) & !$ACC& FIRSTPRIVATE(KF_UV,I_UVDERS_OFFSET,I_UV_OFFSET,KF_FS) #endif DO JGL=1,D%NDGL_FS DO JF=1,2*KF_UV DO JM=0,JLOEN_MAX/2 IGLG = D%NPTRLS(MYSETW)+JGL-1 IOFF_LAT = KF_FS*D%NSTAGTF(JGL) IOFF_UV = IOFF_LAT+(I_UV_OFFSET+JF-1)*(D%NSTAGTF(JGL+1)-D%NSTAGTF(JGL)) IOFF_UV_EWDER = IOFF_LAT+(I_UVDERS_OFFSET+JF-1)*(D%NSTAGTF(JGL+1)-D%NSTAGTF(JGL)) RET_REAL = 0.0_JPRBT RET_COMPLEX = 0.0_JPRBT IF (JM <= G%NMEN(IGLG)) THEN ZIM = REAL(JM,JPRB)*GALD%EXWN RET_REAL = & & -PREEL(IOFF_UV+2*JM+2)*ZIM RET_COMPLEX = & & PREEL(IOFF_UV+2*JM+1)*ZIM ENDIF PREEL(IOFF_UV_EWDER+2*JM+1) = RET_REAL PREEL(IOFF_UV_EWDER+2*JM+2) = RET_COMPLEX ENDDO ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES IF (KF_SCDERS > 0) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) SHARED(KF_SCALARS,PEWDERS,PSCALAR) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IGLG,IOFF_LAT,IOFF_SCALARS_EWDER,IOFF_SCALARS,ZIM,RET_REAL,RET_COMPLEX) & !$ACC& FIRSTPRIVATE(KF_SCALARS,I_SCDERS_OFFSET,I_SC_OFFSET,KF_FS) #endif DO JGL=1,D%NDGL_FS DO JF=1,KF_SCALARS DO JM=0,JLOEN_MAX/2 IGLG = D%NPTRLS(MYSETW)+JGL-1 IOFF_LAT = KF_FS*D%NSTAGTF(JGL) IOFF_SCALARS_EWDER = IOFF_LAT+(I_SCDERS_OFFSET+JF-1)*(D%NSTAGTF(JGL+1)-D%NSTAGTF(JGL)) IOFF_SCALARS = IOFF_LAT+(I_SC_OFFSET+JF-1)*(D%NSTAGTF(JGL+1)-D%NSTAGTF(JGL)) RET_REAL = 0.0_JPRBT RET_COMPLEX = 0.0_JPRBT IF (JM <= G%NMEN(IGLG)) THEN ZIM = REAL(JM,JPRB)*GALD%EXWN RET_REAL = & & -PREEL(IOFF_SCALARS+2*JM+2)*ZIM RET_COMPLEX = & & PREEL(IOFF_SCALARS+2*JM+1)*ZIM ENDIF ! The rest from G_NMEN(IGLG+1)...MAX is zero truncated PREEL(IOFF_SCALARS_EWDER+2*JM+1) = RET_REAL PREEL(IOFF_SCALARS_EWDER+2*JM+2) = RET_COMPLEX ENDDO ENDDO ENDDO ENDIF #ifdef ACCGPU !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('EFSC_MOD:EFSC',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFSC END MODULE EFSC_MODectrans-1.8.0/src/etrans/gpu/internal/espnormd_mod.F900000664000175000017500000000252015174631767023023 0ustar alastairalastairMODULE ESPNORMD_MOD CONTAINS SUBROUTINE ESPNORMD(PSPEC,KFLD,PMET,PSM) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPMALD_DISTR ,ONLY : DALD ! IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PMET(0:R%NSPEC_G) INTEGER(KIND=JPIM) ,INTENT(IN) :: KFLD REAL(KIND=JPRB) ,INTENT(OUT) :: PSM(:,:) INTEGER(KIND=JPIM) :: JM ,JFLD ,JN ,IM ,ISP INTEGER(KIND=JPIM) :: IN,ISPE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESPNORMD_MOD:ESPNORMD',0,ZHOOK_HANDLE) !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JM,IM,JN,ISP,JFLD,IN,ISPE) DO JM=1,D%NUMP PSM(:,JM) = 0.0_JPRB IM = D%MYMS(JM) IN=DALD%NCPL2M(IM)/2 - 1 DO JN=0,IN ISP=DALD%NESM0(IM) + (JN)*4 ISPE=DALD%NPME (IM) + JN DO JFLD=1,KFLD PSM(JFLD,JM) =PSM(JFLD,JM)& & + PMET(ISPE) *& & ( PSPEC(JFLD,ISP )**2 + PSPEC(JFLD,ISP+1)**2 +& & PSPEC(JFLD,ISP+2)**2 + PSPEC(JFLD,ISP+3)**2 ) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO IF (LHOOK) CALL DR_HOOK('ESPNORMD_MOD:ESPNORMD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESPNORMD END MODULE ESPNORMD_MOD ectrans-1.8.0/src/etrans/gpu/internal/espnsde_mod.F900000664000175000017500000000537615174631767022651 0ustar alastairalastairMODULE ESPNSDE_MOD CONTAINS SUBROUTINE ESPNSDE(KF_SCALARS,PF,PNSD) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DISTR ,ONLY : D USE TPMALD_DISTR ,ONLY : DALD USE TPMALD_GEO ,ONLY : GALD !**** *SPNSDE* - Compute North-South derivative in spectral space ! Purpose. ! -------- ! In Laplace space compute the the North-south derivative !** Interface. ! ---------- ! CALL SPNSDE(...) ! Explicit arguments : ! -------------------- ! KM -zonal wavenumber (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PF (NLEI1,2*KF_SCALARS) - input field (input) ! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : YOMLAP ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From SPNSDE in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB), INTENT(IN) :: PF(:,:,:) REAL(KIND=JPRB), INTENT(OUT) :: PNSD(:,:,:) INTEGER(KIND=JPIM) :: J, JN,IN, JM, IM, JNMAX REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. COMPUTE NORTH SOUTH DERIVATIVE. ! ------------------------------- !* 1.1 COMPUTE IF (LHOOK) CALL DR_HOOK('ESPNSDE_MOD:ESPNSDE',0,ZHOOK_HANDLE) JNMAX = MAXVAL (DALD%NCPL2M) !$acc parallel loop collapse (3) private (JM, J, JN, IM, IN, ZIN) & !$acc & present (D,DALD,D%NUMP, D%MYMS, DALD%NCPL2M, PNSD, PF) DO J=1,2*KF_SCALARS DO JM = 1, D%NUMP DO JN=1,JNMAX,2 IM = D%MYMS(JM) IF (JN <= DALD%NCPL2M(IM)) THEN IN =(JN-1)/2 ZIN = REAL(IN,JPRB)*GALD%EYWN PNSD(JN ,JM,J) = -ZIN*PF(JN+1,JM,J) PNSD(JN+1,JM,J) = ZIN*PF(JN ,JM,J) ENDIF ENDDO ENDDO ENDDO !$acc end parallel loop IF (LHOOK) CALL DR_HOOK('ESPNSDE_MOD:ESPNSDE',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESPNSDE END MODULE ESPNSDE_MODectrans-1.8.0/src/etrans/gpu/internal/tpmald_tcdis.F900000664000175000017500000000020315174631767023000 0ustar alastairalastairMODULE TPMALD_TCDIS ! useless USE PARKIND1 ,ONLY : JPRB IMPLICIT NONE SAVE REAL(KIND=JPRB) :: TCDIS END MODULE TPMALD_TCDIS ectrans-1.8.0/src/etrans/gpu/internal/tpmald_fields.F900000664000175000017500000000060715174631767023150 0ustar alastairalastairMODULE TPMALD_FIELDS USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE SAVE TYPE ALDFIELDS_TYPE REAL(KIND=JPRB) ,POINTER :: RLEPINM(:) ! eigen-values of the inverse Laplace operator END TYPE ALDFIELDS_TYPE TYPE(ALDFIELDS_TYPE),ALLOCATABLE,TARGET :: ALDFIELDS_RESOL(:) TYPE(ALDFIELDS_TYPE),POINTER :: FALD REAL(KIND=JPRB) ,ALLOCATABLE :: FALD_RLEPINM(:) END MODULE TPMALD_FIELDS ectrans-1.8.0/src/etrans/gpu/internal/cpl_int_mod.F900000664000175000017500000000203115174631767022621 0ustar alastairalastairMODULE CPL_INT_MOD CONTAINS SUBROUTINE CPL_INT(PGTF,KENDROWL,KFIELDS,KFFIELDS,KLEN,KSTA,CPL_PROC,KPTRGP) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KENDROWL INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KFFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KLEN INTEGER(KIND=JPIM), INTENT(IN) :: KSTA(KENDROWL) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB), INTENT(INOUT) :: PGTF(KFIELDS,KLEN) EXTERNAL CPL_PROC INTEGER(KIND=JPIM) :: IPTRGP(KFIELDS) INTEGER(KIND=JPIM) :: J REAL(KIND=JPHOOK) :: ZHOOK_HANDLE !-------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('CPL_INT_MOD:CPL_INT',0,ZHOOK_HANDLE) IF(PRESENT(KPTRGP)) THEN IPTRGP(:)=KPTRGP(1:KFIELDS) ELSE DO J=1,KFIELDS IPTRGP(J)=J ENDDO ENDIF CALL CPL_PROC(PGTF,KENDROWL,KFIELDS,KFFIELDS,KLEN,KSTA,IPTRGP) IF (LHOOK) CALL DR_HOOK('CPL_INT_MOD:CPL_INT',1,ZHOOK_HANDLE) END SUBROUTINE CPL_INT END MODULE CPL_INT_MOD ectrans-1.8.0/src/etrans/gpu/internal/suestaonl_mod.F900000664000175000017500000003210715174631767023215 0ustar alastairalastairMODULE SUESTAONL_MOD CONTAINS SUBROUTINE SUESTAONL(KMEDIAP,KRESTM,LDWEIGHTED_DISTR,PWEIGHT,PMEDIAP,KPROCAGP) !**** *SUESTAONL * - Routine to initialize parallel environment, TAL ! Purpose. ! -------- ! Initialize D%NSTA and D%NONL. ! Calculation of distribution of grid points to processors : ! Splitting of grid in B direction !** Interface. ! ---------- ! *CALL* *SUESTAONL * ! Explicit arguments : ! -------------------- ! KMEDIAP - mean number of grid points per PE ! KRESTM - number of PEs with one extra point ! LDWEIGHTED_DISTR -true if weighted distribution ! PWEIGHT -weight per grid-point if weighted ! distribution ! PMEDIAP -mean weight per PE if weighted ! distribution ! KPROCAGP -number of grid points per A set ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. NONE. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option. ! - removal of LRPOLE in YOMCT0. ! - removal of code under LRPOLE. ! Modified 98-12-04 C. Fischer: merge with SUESTAONL (Aladin) ! 03-03-03 G. Radnoti: no merge: only difference with ! sustaonl: ezone added to last a-set ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! O.Spaniel Oct-2004 phasing for AL29 ! A.Bogatchev Sep-2010 phasing for AL37 ! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS ! R. El Khatib 26-Apr-2018 vectorization ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_ALLGATHERV, MPL_RECV, MPL_SEND USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, MTAGPART, NPRCIDS, MYPROC, NPROC USE TPMALD_DIM ,ONLY : RALD USE SET2PE_MOD ,ONLY : SET2PE USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & & N_REGIONS, N_REGIONS_NS, N_REGIONS_EW USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(IN) :: KRESTM REAL(KIND=JPRD),INTENT(IN) :: PWEIGHT(:) LOGICAL,INTENT(IN) :: LDWEIGHTED_DISTR REAL(KIND=JPRD),INTENT(IN) :: PMEDIAP INTEGER(KIND=JPIM),INTENT(IN) :: KPROCAGP(:) INTEGER(KIND=JPIM) :: IXPTLAT(R%NDGL), ILSTPTLAT(R%NDGL) INTEGER(KIND=JPIM) :: ICHK(R%NDLON,R%NDGL), ICOMBUF(R%NDGL*N_REGIONS_EW*2) INTEGER(KIND=JPIM) :: I1, I2, IBUFLEN, IDGLG, & & IGL, IGL1, IGL2, IGLOFF, IGPTA, & & IGPTPRSETS, IGPTS, IGPTSP, ILEN, ILRECV, & & ILSEND, INPLAT, INXLAT, IPOS, & & IPROCB, IPTSRE, IRECV, & & IREST, ISEND, ITAG, JA, JB, JGL, JL, JNPTSRE, & & ILAT, ILON, ILOEN INTEGER(KIND=JPIM),ALLOCATABLE :: ICOMBUFG(:) REAL(KIND=JPRB),ALLOCATABLE :: ZWEIGHT(:,:) INTEGER(KIND=JPIM) :: JJ, ILENG(NPROC), IOFF(NPROC) LOGICAL :: LLABORT LOGICAL :: LLP1,LLP2 REAL(KIND=JPRB) :: ZLAT, ZLAT1(R%NDGL), ZCOMP REAL(KIND=JPRB) :: ZDIVID(R%NDGL),ZXPTLAT(R%NDGL) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ----------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('SUESTAONL_MOD:SUESTAONL',0,ZHOOK_HANDLE) IXPTLAT (:)=999999 ILSTPTLAT(:)=999999 LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IBUFLEN = R%NDGL*N_REGIONS_EW*2 IDGLG = R%NDGL I1 = MAX( 1,D%NFRSTLAT(MY_REGION_NS)-D%NFRSTLOFF) I2 = MIN(IDGLG,D%NLSTLAT (MY_REGION_NS)-D%NFRSTLOFF) ILEN = D%NLSTLAT(MY_REGION_NS) - D%NFRSTLAT(MY_REGION_NS)+1 IGPTPRSETS = SUM(G%NLOEN(1:D%NFRSTLAT(MY_REGION_NS)-1)) IF (D%LSPLIT) THEN IF( LEQ_REGIONS )THEN IGPTA=0 DO JA=1,MY_REGION_NS-1 IGPTA = IGPTA + KPROCAGP(JA) ENDDO IGPTS = KPROCAGP(MY_REGION_NS) ELSE IF (MY_REGION_NS <= KRESTM.OR.KRESTM == 0) THEN IF (MY_REGION_NS < N_REGIONS_NS) THEN IGPTS = KMEDIAP IGPTA = KMEDIAP*(MY_REGION_NS-1) ELSE IGPTS = KMEDIAP+SUM(G%NLOEN(RALD%NDGUX+1:R%NDGL)) IGPTA = KMEDIAP*(MY_REGION_NS-1) ENDIF ELSE IF (MY_REGION_NS < N_REGIONS_NS) THEN IGPTS = KMEDIAP-1 IGPTA = KMEDIAP*KRESTM+IGPTS*(MY_REGION_NS-1-KRESTM) ELSE IGPTS = KMEDIAP-1+SUM(G%NLOEN(RALD%NDGUX+1:R%NDGL)) IGPTA = KMEDIAP*KRESTM+(KMEDIAP-1)*(MY_REGION_NS-1-KRESTM) ENDIF ENDIF ENDIF ELSE IGPTA = IGPTPRSETS IGPTS = SUM(G%NLOEN(D%NFRSTLAT(MY_REGION_NS):D%NLSTLAT(MY_REGION_NS))) ENDIF IGPTSP = IGPTS/N_REGIONS(MY_REGION_NS) IREST = IGPTS-N_REGIONS(MY_REGION_NS)*IGPTSP IXPTLAT(1) = IGPTA-IGPTPRSETS+1 ZXPTLAT(1) = REAL(IXPTLAT(1)) ILSTPTLAT(1) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)) INPLAT = G%NLOEN(D%NFRSTLAT(MY_REGION_NS))-IXPTLAT(1)+1 DO JGL=2,ILEN IXPTLAT(JGL) = 1 ZXPTLAT(JGL) = 1.0_JPRB ILSTPTLAT(JGL) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) INPLAT = INPLAT+G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) ENDDO ILSTPTLAT(ILEN) = G%NLOEN(D%NLSTLAT(MY_REGION_NS))-INPLAT+IGPTS DO JB=1,N_REGIONS_EW DO JGL=1,R%NDGL+N_REGIONS_NS-1 D%NSTA(JGL,JB) = 0 D%NONL(JGL,JB) = 0 ENDDO ENDDO ! grid point decomposition ! --------------------------------------- DO JGL=1,ILEN ZDIVID(JGL)=1._JPRB/REAL(G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1),JPRB) ENDDO IF( LDWEIGHTED_DISTR )THEN ALLOCATE(ZWEIGHT(G%NLOEN(R%NDGL/2),R%NDGL)) IGL=0 DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) IGL=IGL+1 ZWEIGHT(JL,JGL)=PWEIGHT(IGL) ENDDO ENDDO ZCOMP=0 IGPTS=0 ENDIF DO JB=1,N_REGIONS(MY_REGION_NS) IF( .NOT.LDWEIGHTED_DISTR )THEN IF (JB <= IREST) THEN IPTSRE = IGPTSP+1 ELSE IPTSRE = IGPTSP ENDIF DO JNPTSRE=1,IPTSRE ZLAT = 1._JPRB DO JGL=1,ILEN ZLAT1(JGL) = (ZXPTLAT(JGL)-1.0_JPRB)*ZDIVID(JGL) ENDDO DO JGL=1,ILEN IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN IF (ZLAT1(JGL) < ZLAT) THEN ZLAT=ZLAT1(JGL) INXLAT = JGL ENDIF ENDIF ENDDO IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN IGL=D%NPTRFLOFF+INXLAT IF (D%NSTA(IGL,JB) == 0) THEN D%NSTA(IGL,JB) = IXPTLAT(INXLAT) ENDIF D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 ENDIF IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 ZXPTLAT(INXLAT) = REAL(IXPTLAT(INXLAT),JPRB) ENDDO ELSE DO WHILE ( (JB < N_REGIONS(MY_REGION_NS) .AND. ZCOMP < PMEDIAP) & & .OR. (JB == N_REGIONS(MY_REGION_NS) .AND. IGPTS < KPROCAGP(MY_REGION_NS)) ) IGPTS = IGPTS + 1 ZLAT = 1._JPRB DO JGL=1,ILEN ZLAT1(JGL) = (ZXPTLAT(JGL)-1.0_JPRB)*ZDIVID(JGL) ENDDO DO JGL=1,ILEN IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN IF (ZLAT1(JGL) < ZLAT) THEN ZLAT = ZLAT1(JGL) INXLAT = JGL ENDIF ENDIF ENDDO IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN IGL=D%NPTRFLOFF+INXLAT IF (D%NSTA(IGL,JB) == 0) THEN D%NSTA(IGL,JB) = IXPTLAT(INXLAT) ENDIF D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 IF(IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1)THEN CALL ABORT_TRANS(' SUSTAONL: IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1') ENDIF ILON=D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 ILAT=D%NFRSTLAT(MY_REGION_NS)+INXLAT-1 ILOEN=G%NLOEN(ILAT) IF(ILON<1.OR.ILON>ILOEN)THEN CALL ABORT_TRANS(' SUSTAONL: ILON<1.OR.ILON>ILOEN') ENDIF ZCOMP = ZCOMP + ZWEIGHT(ILON,ILAT) ENDIF IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 ZXPTLAT(INXLAT) = REAL(IXPTLAT(INXLAT),JPRB) ENDDO ZCOMP = ZCOMP - PMEDIAP ENDIF ENDDO IF( LDWEIGHTED_DISTR )THEN DEALLOCATE(ZWEIGHT) ENDIF ! Exchange local partitioning info to produce global view IF( NPROC > 1 )THEN IF( LEQ_REGIONS )THEN ITAG = MTAGPART IPOS = 0 DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 IPOS = IPOS+1 ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,MY_REGION_EW) IPOS = IPOS+1 ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,MY_REGION_EW) ENDDO IF( IPOS > IBUFLEN )THEN CALL ABORT_TRANS(' SUSTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') ENDIF ILSEND = IPOS DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(IRECV,JA,JB,0,0) ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 ILENG(NPRCIDS(IRECV))=ILEN ENDDO ENDDO IOFF(1)=0 DO JJ=2,NPROC IOFF(JJ)=IOFF(JJ-1)+ILENG(JJ-1) ENDDO ALLOCATE(ICOMBUFG(SUM(ILENG(:)))) CALL MPL_ALLGATHERV(ICOMBUF(1:ILSEND),ICOMBUFG,ILENG,CDSTRING='SUSTAONL') DO JA=1,N_REGIONS_NS IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JB=1,N_REGIONS(JA) CALL SET2PE(IRECV,JA,JB,0,0) IF(IRECV /= MYPROC) THEN ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 IPOS = IOFF(NPRCIDS(IRECV)) DO JGL=IGL1,IGL2 IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 IPOS = IPOS+1 D%NSTA(IGL,JB) = ICOMBUFG(IPOS) IPOS = IPOS+1 D%NONL(IGL,JB) = ICOMBUFG(IPOS) ENDDO ENDIF ENDDO ENDDO DEALLOCATE(ICOMBUFG) ELSE ITAG = MTAGPART IPOS = 0 DO JB=1,N_REGIONS(MY_REGION_NS) DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 IPOS = IPOS+1 ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,JB) IPOS = IPOS+1 ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,JB) ENDDO ENDDO IF( IPOS > IBUFLEN )THEN CALL ABORT_TRANS(' SUESTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') ENDIF ILSEND = IPOS DO JA=1,N_REGIONS_NS CALL SET2PE(ISEND,JA,MY_REGION_EW,0,0) IF(ISEND /= MYPROC) THEN CALL MPL_SEND(ICOMBUF(1:ILSEND),KDEST=NPRCIDS(ISEND),KTAG=ITAG, & & CDSTRING='SUESTAONL:') ENDIF ENDDO DO JA=1,N_REGIONS_NS CALL SET2PE(IRECV,JA,MY_REGION_EW,0,0) IF(IRECV /= MYPROC) THEN ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*N_REGIONS(JA)*2 CALL MPL_RECV(ICOMBUF(1:ILEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, & & KOUNT=ILRECV,CDSTRING='SUESTAONL:') IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IPOS = 0 DO JB=1,N_REGIONS(JA) DO JGL=IGL1,IGL2 IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 IPOS = IPOS+1 D%NSTA(IGL,JB) = ICOMBUF(IPOS) IPOS = IPOS+1 D%NONL(IGL,JB) = ICOMBUF(IPOS) ENDDO ENDDO ENDIF ENDDO ENDIF ENDIF ! Confirm consistency of global partitioning, specifically testing for ! multiple assignments of same grid point and unassigned grid points LLABORT = .FALSE. DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) ICHK(JL,JGL) = 1 ENDDO ENDDO DO JA=1,N_REGIONS_NS IGLOFF = D%NPTRFRSTLAT(JA) DO JB=1,N_REGIONS(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JGL=IGL1,IGL2 IGL = IGLOFF+JGL-IGL1 DO JL=D%NSTA(IGL,JB),D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 IF( ICHK(JL,JGL) /= 1 )THEN WRITE(NOUT,'(" SUESTAONL : seta=",i4," setb=",i4,& & " row=",I4," sta=",I4," INVALID GRID POINT")')& & JA,JB,JGL,JL WRITE(0,'(" SUESTAONL : seta=",i4," setb=",i4,& & " ROW=",I4," sta=",I4," INVALID GRID POINT")')& & JA,JB,JGL,JL LLABORT = .TRUE. ENDIF ICHK(JL,JGL) = 2 ENDDO ENDDO ENDDO ENDDO DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) IF( ICHK(JL,JGL) /= 2 )THEN WRITE(NOUT,'(" SUESTAONL : row=",i4," sta=",i4,& & " GRID POINT NOT ASSIGNED")') JGL,JL LLABORT = .TRUE. ENDIF ENDDO ENDDO IF( LLABORT )THEN WRITE(NOUT,'(" SUESTAONL : inconsistent partitioning")') CALL ABORT_TRANS(' SUESTAONL: inconsistent partitioning') ENDIF IF (LLP1) THEN WRITE(UNIT=NOUT,FMT='('' OUTPUT FROM ROUTINE SUESTAONL '')') WRITE(UNIT=NOUT,FMT='('' '')') WRITE(UNIT=NOUT,FMT='('' PARTITIONING INFORMATION '')') WRITE(UNIT=NOUT,FMT='('' '')') IPROCB = MIN(32,N_REGIONS_EW) WRITE(UNIT=NOUT,FMT='(17X," SETB=",32(1X,I3))') (JB,JB=1,IPROCB) DO JA=1,N_REGIONS_NS IPROCB = MIN(32,N_REGIONS(JA)) WRITE(UNIT=NOUT,FMT='('' '')') IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JGL=IGL1,IGL2 IGL=IGLOFF+JGL-IGL1 WRITE(UNIT=NOUT,FMT='(" SETA=",I3," LAT=",I3," NSTA=",& & 32(1X,I3))') JA,JGL,(D%NSTA(IGL,JB),JB=1,IPROCB) WRITE(UNIT=NOUT,FMT='(" SETA=",I3," LAT=",I3," D%NONL=",& & 32(1X,I3))') JA,JGL,(D%NONL(IGL,JB),JB=1,IPROCB) WRITE(UNIT=NOUT,FMT='('' '')') ENDDO WRITE(UNIT=NOUT,FMT='('' '')') ENDDO WRITE(UNIT=NOUT,FMT='('' '')') WRITE(UNIT=NOUT,FMT='('' '')') ENDIF IF (LHOOK) CALL DR_HOOK('SUESTAONL_MOD:SUESTAONL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE SUESTAONL END MODULE SUESTAONL_MOD ectrans-1.8.0/src/etrans/gpu/internal/einv_trans_ctl_mod.F900000664000175000017500000001633615174631767024220 0ustar alastairalastairMODULE EINV_TRANS_CTL_MOD CONTAINS SUBROUTINE EINV_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& & KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PSPMEANU,PSPMEANV) !**** *EINV_TRANS_CTL* - Control routine for inverse spectral transform. ! Purpose. ! -------- ! Control routine for the inverse spectral transform !** Interface. ! ---------- ! CALL EINV_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! 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. ! FSPGL_PROC - external procedure to be executed in fourier space ! before transposition ! PGP(:,:,:) - gridpoint fields (output) ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! vorticity : KF_UV_G fields ! divergence : KF_UV_G fields ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! N-S derivative of scalar fields : KF_SCALARS_G fields ! E-W derivative of u : KF_UV_G fields ! E-W derivative of v : KF_UV_G fields ! E-W derivative of scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NPROMATR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, GROWING_ALLOCATION ! USE ELTINV_MOD USE TRMTOL_PACK_UNPACK, ONLY : TRMTOL_UNPACK, TRMTOL_UNPACK_HANDLE, PREPARE_TRMTOL_UNPACK USE TRMTOL_MOD USE EFSC_MOD USE EFTINV_MOD USE FTINV_MOD, ONLY : FTINV_HANDLE, PREPARE_FTINV USE TRLTOG_MOD USE BUFFERED_ALLOCATOR_MOD IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) 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(:) REAL(KIND=JPRB) ,OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) ! Local variables REAL(KIND=JPRB), POINTER :: PREEL(:), FOUBUF(:), FOUBUF_IN(:), PREEL_REAL(:) INTEGER(KIND=JPIM) :: ILEI2, IDIM1 TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR TYPE(FTINV_HANDLE) :: HFTINV TYPE(ELTINV_HANDLE) :: HELTINV TYPE(TRMTOL_HANDLE) :: HTRMTOL TYPE(TRMTOL_UNPACK_HANDLE) :: HTRMTOL_UNPACK TYPE(TRLTOG_HANDLE) :: HTRLTOG REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Perform transform IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTL_MOD:EINV_TRANS_CTL',0,ZHOOK_HANDLE) IF(NPROMATR > 0) THEN print *, "This is currently not supported and/or tested (NPROMATR > 0)" stop 24 ENDIF ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS IDIM1 = 2*KF_OUT_LT ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() HELTINV = PREPARE_ELTINV(ALLOCATOR,KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT) ! ZFFT, FOUBUF_IN HTRMTOL = PREPARE_TRMTOL(ALLOCATOR,KF_OUT_LT) ! FOUBUF HTRMTOL_UNPACK = PREPARE_TRMTOL_UNPACK(ALLOCATOR,KF_FS) ! HREEL HFTINV = PREPARE_FTINV(ALLOCATOR,KF_FS) ! HREEL_REAL HTRLTOG = PREPARE_TRLTOG(ALLOCATOR,KF_FS,KF_GP) ! COMBUFR and COMBUFS CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) IF(KF_OUT_LT > 0) THEN CALL GSTATS(1647,0) CALL ELTINV(ALLOCATOR, HELTINV, KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,FOUBUF_IN,& & PSPVOR,PSPDIV,PSPSCALAR ,& & PSPSC3A,PSPSC3B,PSPSC2 , & & FSPGL_PROC=FSPGL_PROC,PSPMEANU=PSPMEANU,PSPMEANV=PSPMEANV) CALL GSTATS(1647,1) CALL GSTATS(152,0) CALL TRMTOL(ALLOCATOR,HTRMTOL,FOUBUF_IN,FOUBUF,KF_OUT_LT) CALL TRMTOL_UNPACK(ALLOCATOR,HTRMTOL_UNPACK,FOUBUF,PREEL,KF_OUT_LT,KF_FS) ! Formerly known as fourier_in routine CALL GSTATS(152,1) ENDIF IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN CALL EFSC(PREEL, KF_UV, KF_SCALARS, KF_SCDERS,KF_FS) ENDIF IF ( KF_FS > 0 ) THEN CALL EFTINV(ALLOCATOR,HFTINV,PREEL,PREEL_REAL,KF_FS) ENDIF CALL TRLTOG(ALLOCATOR,HTRLTOG,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTL_MOD:EINV_TRANS_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EINV_TRANS_CTL END MODULE EINV_TRANS_CTL_MOD ectrans-1.8.0/src/etrans/gpu/internal/easre1b_mod.F900000664000175000017500000000534015174631767022521 0ustar alastairalastairMODULE EASRE1B_MOD CONTAINS SUBROUTINE EASRE1B(KFIELD,PFFT,FOUBUF_IN) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D !**** *ASRE1B* - Recombine antisymmetric and symmetric parts ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *ASRE1B(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields (input-c) ! KM - zonal wavenumber(input-c) ! KMLOC - local version of KM (input-c) ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM (input) ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM (input) ! Implicit arguments : FOUBUF_IN - output buffer (output) ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1B in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRB), INTENT(IN) :: PFFT(:,:,:) REAL(KIND=JPRB), INTENT(OUT) :: FOUBUF_IN(:) INTEGER(KIND=JPIM) :: JFLD, JGL ,IPROC INTEGER(KIND=JPIM) :: IISTAN INTEGER(KIND=JPIM) :: JM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. ! --------------------------------------------------- IF (LHOOK) CALL DR_HOOK('EASRE1B_MOD:EASRE1B',0,ZHOOK_HANDLE) !$acc parallel loop collapse(3) private (JM, JGL, JFLD, IPROC, IISTAN) & !$acc& present (D, R) & !$acc& present (PFFT, D%NSTAGT0B, D%NPNTGTB1, D%NPROCL, D%NUMP, R%NDGL, FOUBUF_IN) & !$acc& copyin(KFIELD) default(none) DO JM = 1, D%NUMP !100 DO JGL=1,R%NDGL !400 DO JFLD =1,2*KFIELD !500 IPROC=D%NPROCL(JGL) IISTAN=(D%NPNTGTB1(JM,JGL))*2*KFIELD FOUBUF_IN(IISTAN+JFLD)=PFFT(JGL,JM,JFLD) ENDDO ENDDO ENDDO !$acc end parallel loop IF (LHOOK) CALL DR_HOOK('EASRE1B_MOD:EASRE1B',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EASRE1B END MODULE EASRE1B_MODectrans-1.8.0/src/etrans/gpu/external/0000775000175000017500000000000015174631767020064 5ustar alastairalastairectrans-1.8.0/src/etrans/gpu/external/etrans_end.F900000664000175000017500000000636215174631767022475 0ustar alastairalastairSUBROUTINE ETRANS_END(CDMODE) !**** *ETRANS_END* - Terminate transform package ! Purpose. ! -------- ! Terminate transform package. Release all allocated arrays. !** Interface. ! ---------- ! CALL ETRANS_END ! Explicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing cy37 after G.Radnoti ! R. El Khatib 02-Mar-2012 Support for mixed multi-resolutions ! R. El Khatib 09-Jul-2013 LENABLED ! R. El Khatib 01-Set-2015 Support for FFTW ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : MSETUP0, NCUR_RESOL, NDEF_RESOL, NMAX_RESOL, LENABLED USE TPM_DIM ,ONLY : R, DIM_RESOL USE TPM_DISTR ,ONLY : D, DISTR_RESOL, NPRCIDS USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL USE TPM_FLT ,ONLY : S, FLT_RESOL USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL USE TPMALD_DISTR ,ONLY : DALD, ALDDISTR_RESOL USE TPMALD_FIELDS ,ONLY : FALD, ALDFIELDS_RESOL USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EQ_REGIONS_MOD ,ONLY : N_REGIONS USE EDEALLOC_RESOL_MOD ,ONLY : EDEALLOC_RESOL IMPLICIT NONE CHARACTER*5, OPTIONAL, INTENT(IN) :: CDMODE ! Local variables CHARACTER*5 :: CLMODE INTEGER(KIND=JPIM) :: JRES REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ETRANS_END',0,ZHOOK_HANDLE) CLMODE='FINAL' IF (PRESENT(CDMODE)) CLMODE=CDMODE IF (CLMODE == 'FINAL') THEN DO JRES=1,NDEF_RESOL CALL EDEALLOC_RESOL(JRES) ENDDO NULLIFY(R) IF (ALLOCATED(DIM_RESOL)) DEALLOCATE(DIM_RESOL) NULLIFY(RALD) IF (ALLOCATED(ALDDIM_RESOL)) DEALLOCATE(ALDDIM_RESOL) !EQ_REGIONS IF (ASSOCIATED(N_REGIONS)) THEN DEALLOCATE(N_REGIONS) NULLIFY (N_REGIONS) ENDIF !TPM_DISTR NULLIFY(D) IF (ALLOCATED(DISTR_RESOL)) DEALLOCATE(DISTR_RESOL) NULLIFY(DALD) IF (ALLOCATED(ALDDISTR_RESOL)) DEALLOCATE(ALDDISTR_RESOL) !TPM_FLT NULLIFY(S) IF (ALLOCATED(FLT_RESOL)) DEALLOCATE(FLT_RESOL) !TPM_FIELDS NULLIFY(F) IF (ALLOCATED(FIELDS_RESOL)) DEALLOCATE(FIELDS_RESOL) NULLIFY(FALD) IF (ALLOCATED(ALDFIELDS_RESOL)) DEALLOCATE(ALDFIELDS_RESOL) !TPM_GEOMETRY NULLIFY(G) IF(ALLOCATED(GEOM_RESOL)) DEALLOCATE(GEOM_RESOL) NULLIFY(GALD) IF(ALLOCATED(ALDGEO_RESOL)) DEALLOCATE(ALDGEO_RESOL) IF (ALLOCATED(LENABLED)) DEALLOCATE(LENABLED) MSETUP0 = 0 NMAX_RESOL = 0 NCUR_RESOL = 0 NDEF_RESOL = 0 ENDIF IF (CLMODE == 'FINAL' .OR. CLMODE == 'INTER') THEN !EQ_REGIONS IF (ASSOCIATED(N_REGIONS)) THEN DEALLOCATE(N_REGIONS) NULLIFY (N_REGIONS) ENDIF !TPM_DISTR IF (ALLOCATED(NPRCIDS)) DEALLOCATE(NPRCIDS) ENDIF IF (LHOOK) CALL DR_HOOK('ETRANS_END',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE ETRANS_END ectrans-1.8.0/src/etrans/gpu/external/egath_grid.F900000664000175000017500000000700315174631767022441 0ustar alastairalastairSUBROUTINE EGATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *EGATH_GRID* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL EGATH_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:,:) - Local spectral array ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE GATH_GRID_CTL_MOD ,ONLY : GATH_GRID_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM),INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFRECV,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EGATH_GRID',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_GRID: KTO TOO SHORT!') ENDIF IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_GRID:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_GRID:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'GATH_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFGATHG) THEN WRITE(NOUT,*)'GATH_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFGATHG CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'GATH_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('GATH_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('GATH_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFRECV) THEN CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL GATH_GRID_CTL(PGPG,KFGATHG,IPROMA,KTO,PGP) IF (LHOOK) CALL DR_HOOK('EGATH_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EGATH_GRID ectrans-1.8.0/src/etrans/gpu/external/esetup_trans.F900000664000175000017500000002467415174631767023075 0ustar alastairalastairSUBROUTINE ESETUP_TRANS(KMSMAX,KSMAX,KDGL,KDGUX,KLOEN,LDSPLIT,& & KTMAX,KRESOL,PEXWN,PEYWN,PWEIGHT,LDGRIDONLY,KNOEXTZL,KNOEXTZG, & & LDUSEFFTW,LD_ALL_FFTW) !**** *ESETUP_TRANS* - Setup transform package for specific resolution ! Purpose. ! -------- ! To setup for making spectral transforms. Each call to this routine ! creates a new resolution up to a maximum of NMAX_RESOL set up in ! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can ! be called. !** Interface. ! ---------- ! CALL ESETUP_TRANS(...) ! Explicit arguments : KLOEN,LDSPLIT are optional arguments ! -------------------- ! KSMAX - spectral truncation required ! KDGL - number of Gaussian latitudes ! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] ! LDSPLIT - true if split latitudes in grid-point space [false] ! KTMAX - truncation order for tendencies? ! KRESOL - the resolution identifier ! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution ! in spectral and grid-point space ! LDGRIDONLY - true if only grid space is required ! LDSPLIT describe the distribution among processors of ! grid-point data and has no relevance if you are using a single processor ! LDUSEFFTW - Use FFTW for FFTs ! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ESETUP_DIMS - setup distribution independent dimensions ! SUEMP_TRANS_PRELEG - first part of setup of distr. environment ! SULEG - Compute Legandre polonomial and Gaussian ! Latitudes and Weights ! ESETUP_GEOM - Compute arrays related to grid-point geometry ! SUEMP_TRANS - Second part of setup of distributed environment ! SUEFFT - setup for FFT ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 02-04-11 A. Bogatchev: Passing of TCDIS ! 02-11-14 C. Fischer: soften test on KDGL ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing cy37 ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 02-Mar-2012 Support for mixed multi-resolutions ! R. El Khatib 09-Aug-2012 %LAM in GEOM_TYPE ! R. El Khatib 14-Jun-2013 LENABLED ! R. El Khatib 01-Sep-2015 Support for FFTW ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, NPRINTLEV, MSETUP0, & & NCUR_RESOL, NDEF_RESOL, NMAX_RESOL, LENABLED USE TPM_DIM ,ONLY : R, DIM_RESOL USE TPM_DISTR ,ONLY : D, DISTR_RESOL,NPROC,NPRTRV, MYPROC USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : FIELDS_RESOL USE TPM_FLT ,ONLY : FLT_RESOL USE TPM_CTL ,ONLY : CTL_RESOL USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL USE TPMALD_DISTR ,ONLY : DALD, ALDDISTR_RESOL USE TPMALD_FIELDS ,ONLY : ALDFIELDS_RESOL, FALD USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE ESETUP_DIMS_MOD ,ONLY : ESETUP_DIMS USE SUEMP_TRANS_MOD ,ONLY : SUEMP_TRANS USE SUEMP_TRANS_PRELEG_MOD ,ONLY : SUEMP_TRANS_PRELEG USE ESETUP_GEOM_MOD ,ONLY : ESETUP_GEOM USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS #ifdef ACCGPU USE OPENACC #endif #ifdef OMPGPU USE OMP_LIB #endif !endif INTERFACE IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KMSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(:) LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT LOGICAL ,OPTIONAL,INTENT(IN) :: LDGRIDONLY INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KTMAX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEXWN REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEYWN REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZG LOGICAL ,OPTIONAL,INTENT(IN) :: LDUSEFFTW LOGICAL ,OPTIONAL,INTENT(IN) :: LD_ALL_FFTW !ifndef INTERFACE ! Local variables LOGICAL :: LLP1,LLP2 #ifdef ACCGPU INTEGER(ACC_DEVICE_KIND) :: IDEVTYPE #endif INTEGER :: INUMDEVS, IUNIT, ISTAT, IDEV, MYGPU INTEGER :: I, J REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESETUP_TRANS',0,ZHOOK_HANDLE) IF(MSETUP0 == 0) THEN CALL ABORT_TRANS('ESETUP_TRANS: SETUP_TRANS0 HAS TO BE CALLED BEFORE ESETUP_TRANS') ENDIF LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE ESETUP_TRANS ===' ! Allocate resolution dependent structures common to global and LAM IF(.NOT. ALLOCATED(DIM_RESOL)) THEN NDEF_RESOL = 1 ALLOCATE(DIM_RESOL(NMAX_RESOL)) ALLOCATE(FIELDS_RESOL(NMAX_RESOL)) ALLOCATE(GEOM_RESOL(NMAX_RESOL)) ALLOCATE(DISTR_RESOL(NMAX_RESOL)) ALLOCATE(FLT_RESOL(NMAX_RESOL)) ALLOCATE(CTL_RESOL(NMAX_RESOL)) GEOM_RESOL(:)%LAM=.FALSE. ALLOCATE(LENABLED(NMAX_RESOL)) LENABLED(:)=.FALSE. ELSE NDEF_RESOL = NDEF_RESOL+1 IF(NDEF_RESOL > NMAX_RESOL) THEN CALL ABORT_TRANS('ESETUP_TRANS:NDEF_RESOL > NMAX_RESOL') ENDIF ENDIF ! Allocate LAM-specific resolution dependent structures IF(.NOT. ALLOCATED(ALDDIM_RESOL)) THEN ALLOCATE(ALDDIM_RESOL(NMAX_RESOL)) ALLOCATE(ALDFIELDS_RESOL(NMAX_RESOL)) ALLOCATE(ALDGEO_RESOL(NMAX_RESOL)) ALLOCATE(ALDDISTR_RESOL(NMAX_RESOL)) ENDIF IF (PRESENT(KRESOL)) THEN KRESOL=NDEF_RESOL ENDIF ! Point at structures due to be initialized CALL ESET_RESOL(NDEF_RESOL) IF(LLP1) WRITE(NOUT,*) '=== DEFINING RESOLUTION ',NCUR_RESOL ! Defaults for optional arguments G%LREDUCED_GRID = .FALSE. D%LGRIDONLY = .FALSE. D%LSPLIT = .FALSE. ! NON-OPTIONAL ARGUMENTS R%NSMAX = KSMAX RALD%NMSMAX=KMSMAX RALD%NDGUX=KDGUX R%NDGL = KDGL RALD%NDGLSUR=KDGL+2 R%NDLON =KLOEN(1) RALD%NLOENS_LON=(/ R%NDLON /) RALD%NOFFSETS_LON=(/ 0 , R%NDLON+2 /) RALD%NLOENS_LAT=(/ R%NDGL /) RALD%NOFFSETS_LAT=(/ 0 , R%NDGL+2 /) ! IMPLICIT argument : G%LAM = .TRUE. IF (KDGL <= 0) THEN CALL ABORT_TRANS ('ESETUP_TRANS: KDGL IS NOT A POSITIVE NUMBER') ENDIF ! Optional arguments ALLOCATE(G%NLOEN(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'NLOEN ',SIZE(G%NLOEN ),SHAPE(G%NLOEN ) IF (G%LREDUCED_GRID) THEN G%NLOEN(:) = KLOEN(1:R%NDGL) ELSE G%NLOEN(:) = R%NDLON ENDIF IF(PRESENT(LDSPLIT)) THEN D%LSPLIT = LDSPLIT ENDIF IF(PRESENT(KTMAX)) THEN R%NTMAX = KTMAX ELSE R%NTMAX = R%NSMAX ENDIF IF(R%NTMAX /= R%NSMAX) THEN !This SHOULD work but I don't know how to test it /MH WRITE(NERR,*) 'R%NTMAX /= R%NSMAX',R%NTMAX,R%NSMAX CALL ABORT_TRANS('ESETUP_TRANS:R%NTMAX /= R%NSMAX HAS NOT BEEN VALIDATED') ENDIF IF(PRESENT(PWEIGHT)) THEN D%LWEIGHTED_DISTR = .TRUE. IF( D%LWEIGHTED_DISTR .AND. .NOT.D%LSPLIT )THEN CALL ABORT_TRANS('SETUP_TRANS: LWEIGHTED_DISTR=T AND LSPLIT=F NOT SUPPORTED') ENDIF IF(SIZE(PWEIGHT) /= SUM(G%NLOEN(:)) )THEN CALL ABORT_TRANS('SETUP_TRANS:SIZE(PWEIGHT) /= SUM(G%NLOEN(:))') ENDIF ALLOCATE(D%RWEIGHT(SIZE(PWEIGHT))) D%RWEIGHT(:)=PWEIGHT(:) ELSE D%LWEIGHTED_DISTR = .FALSE. ENDIF IF(PRESENT(LDGRIDONLY)) THEN D%LGRIDONLY=LDGRIDONLY ENDIF IF (PRESENT(KNOEXTZL)) THEN R%NNOEXTZL=KNOEXTZL ELSE R%NNOEXTZL=0 ENDIF IF (PRESENT(KNOEXTZG)) THEN R%NNOEXTZG=KNOEXTZG ELSE R%NNOEXTZG=0 ENDIF ! Setup resolution dependent structures ! ------------------------------------- ! Setup distribution independent dimensions CALL ESETUP_DIMS IF (PRESENT(PEXWN)) GALD%EXWN=PEXWN IF (PRESENT(PEYWN)) GALD%EYWN=PEYWN ! GPU stuff: from setup_trans.F90 #ifdef ACCGPU IDEVTYPE=ACC_GET_DEVICE_TYPE() INUMDEVS = ACC_GET_NUM_DEVICES(IDEVTYPE) MYGPU = MOD(MYPROC-1,INUMDEVS) CALL ACC_SET_DEVICE_NUM(MYGPU, IDEVTYPE) MYGPU = ACC_GET_DEVICE_NUM(IDEVTYPE) !ISTAT = CUDA_GETDEVICE(IDEV) #endif #ifdef ACCGPU !$ACC ENTER DATA COPYIN(D,R,G) !$ACC ENTER DATA & !$ACC& COPYIN(D%NUMP,D%MYMS,D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,D%NPROCM,D%NPTRLS,D%MSTABF) & !$ACC& COPYIN(R%NDGNH,R%NSMAX) & !$ACC& COPYIN(G%NDGLU,G%NMEN,G%NLOEN) #endif #ifdef OMPGPU !$OMP TARGET ENTER DATA MAP(TO:F,D,D%NUMP,D%MYMS,R,R%NDGNH,R%NSMAX,G,G%NDGLU) !$OMP TARGET ENTER DATA MAP(TO:D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,G%NMEN,D%NPROCM,D%NPTRLS,G,G%NLOEN,D%MSTABF) #endif ! First part of setup of distributed environment CALL SUEMP_TRANS_PRELEG CALL GSTATS(1802,0) ! Compute arrays related to grid-point geometry CALL ESETUP_GEOM ! Second part of setup of distributed environment CALL SUEMP_TRANS ! Initialize Fast Fourier Transform package CALL GSTATS(1802,1) ! Signal the current resolution is active LENABLED(NDEF_RESOL)=.TRUE. #ifdef ACCGPU WRITE(NOUT,*) 'Using OpenACC' #endif #ifdef OMPGPU WRITE(NOUT,*) 'Using OpenMP offloading' #endif #ifdef ACCGPU !$ACC ENTER DATA COPYIN(R,D,G,DALD,FALD,RALD) !$ACC ENTER DATA COPYIN(R%NSMAX,R%NTMAX,R%NDGL,R%NDGNH,D%NSTAGT0B,D%NSTAGT1B,& !$ACC& D%NPNTGTB1,D%NPROCL,D%NUMP,D%NDGL_FS,D%MYMS,D%NASM0,D%NSTAGTF,D%MSTABF,& !$ACC& D%NPNTGTB0,D%NPROCM,D%NPTRLS,G%NDGLU,G%NMEN,G%NLOEN,& !$ACC& DALD%NESM0,DALD%NCPL2M, DALD%NPME, FALD%RLEPINM, & !$ACC& RALD%NLOENS_LON,RALD%NOFFSETS_LON,RALD%NLOENS_LAT,RALD%NOFFSETS_LAT) #endif #ifdef OMPGPU !$OMP TARGET ENTER DATA MAP(TO:R%NSMAX,R%NTMAX,R%NDGL,R%NDGNH,D%NSTAGT0B,D%NSTAGT1B) !$OMP TARGET ENTER DATA MAP(TO:D%NPNTGTB1,D%NPROCL,D%NUMP,D%NDGL_FS,D%MYMS,D%NASM0,D%NSTAGTF,D%MSTABF) !$OMP TARGET ENTER DATA MAP(TO:D%NPNTGTB0,D%NPROCM,D%NPTRLS,G%NDGLU,G%NMEN,G%NLOEN) !$OMP TARGET ENTER DATA MAP(TO:DALD%NESM0,DALD%NCPL2M, DALD%NPME, FALD%RLEPINM) !$OMP TARGET ENTER DATA MAP(TO:RALD%NLOENS_LON,RALD%NOFFSETS_LON,RALD%NLOENS_LAT,RALD%NOFFSETS_LAT #endif WRITE(NOUT,*) '===GPU arrays successfully allocated' #ifdef ACCGPU !$ACC wait #endif #ifdef OMPGPU !$OMP BARRIER #endif IF (LHOOK) CALL DR_HOOK('ESETUP_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) !endif INTERFACE END SUBROUTINE ESETUP_TRANS ectrans-1.8.0/src/etrans/gpu/external/einv_transad.F900000664000175000017500000005430215174631767023025 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EINV_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,PMEANU,PMEANV) !**** *EINV_TRANSAD* - Inverse spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform - adjoint !** Interface. ! ---------- ! CALL EINV_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. ESET_RESOL - set resolution ! ---------- ELTDIR_CTLAD - control of Legendre transform ! EFTDIR_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti: like in direct code: IF_SCALARS_G fields (if pspscalar ! present and LDSCDERS) ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !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 ESET_RESOL_MOD ,ONLY : ESET_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) 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(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANV(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC !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('EINV_TRANSAD',0,ZHOOK_HANDLE) CALL ABORT_TRANS('Adjoint code of ectrans/lam not implemented on GPU yet') #ifdef UNDEF CALL GSTATS(1809,0) ! Set current resolution CALL ESET_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,*) 'EINV_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('EINV_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,*) 'EINV_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('EINV_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('EINV_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,*) 'EINV_TRANSAD:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('EINV_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('EINV_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,*) 'EINV_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('EINV_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,*) 'EINV_TRANSAD:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('EINV_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("EINV_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING") ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'EINV_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& & UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS("EINV_TRANSAD : PSPVOR TOO SHORT") ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS("EINV_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("EINV_TRANSAD : PSPDIV TOO SHORT") ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'EINV_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('EINV_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('EINV_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('EINV_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('EINV_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('EINV_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('EINV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IF(PRESENT(PGPUV)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGPUV CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3A)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP3A CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3B)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP3B CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP2)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'EINV_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('EINV_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('EINV_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('EINV_TRANSAD:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'EINV_TRANSAD:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < IF_UV_PAR) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('EINV_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,*)'EINV_TRANSAD:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('EINV_TRANSAD:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('EINV_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,*)'EINV_TRANSAD:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'EINV_TRANSAD:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('EINV_TRANSAD:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('EINV_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,*)'EINV_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'EINV_TRANSAD:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('EINV_TRANSAD:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1809,1) ! ------------------------------------------------------------------ ! Perform transform CALL EINV_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,& & PMEANU,PMEANV) #endif IF (LHOOK) CALL DR_HOOK('EINV_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EINV_TRANSAD ectrans-1.8.0/src/etrans/gpu/external/einv_trans.F900000664000175000017500000005323415174631767022523 0ustar alastairalastairSUBROUTINE EINV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & FSPGL_PROC,& & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) !**** *EINV_TRANS* - Inverse spectral transform. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform !** Interface. ! ---------- ! CALL EINV_TRANS(...) ! Explicit arguments : All arguments 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 ! ---------- LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields ! and derivatives (IF_SCALARS_G) ! Y. Seity and G. Radnoti : 03-09-29 : phasing for AL27 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !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 ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EINV_TRANS_CTL_MOD ,ONLY : EINV_TRANS_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: 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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMEANV(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC !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('EINV_TRANS',0,ZHOOK_HANDLE) CALL GSTATS(1807,0) ! Set current resolution CALL ESET_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_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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(.NOT. PRESENT(PSPSCALAR) ) THEN CALL ABORT_TRANS('INV_TRANS : KVSETSC PRESENT BUT PSPSCALAR MISSING') ENDIF IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN WRITE(NERR,*) 'INV_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_TRANS: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_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_TRANS: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_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS& & ('INV_TRANS: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_TRANS: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_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_G > 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_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('INV_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('INV_TRANS : 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IF(PRESENT(PGPUV)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGPUV CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3A)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3A CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3B)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3B CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP2)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'INV_TRANS: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_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS: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_TRANS:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('INV_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < IF_UV_PAR) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1807,1) ! ------------------------------------------------------------------ ! Perform transform CALL EINV_TRANS_CTL(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,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV ) IF (LHOOK) CALL DR_HOOK('EINV_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EINV_TRANS ectrans-1.8.0/src/etrans/gpu/external/edir_trans.F900000664000175000017500000004472115174631767022506 0ustar alastairalastairSUBROUTINE EDIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV,AUX_PROC) !**** *EDIR_TRANS* - Direct spectral transform (from grid-point to spectral). ! Purpose. ! -------- ! Interface routine for the direct spectral transform !** Interface. ! ---------- ! CALL EDIR_TRANS(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 (input) ! 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): ! 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) ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! PMEANU(:),PMEANV(:) - mean wind ! AUX_PROC - optional external procedure for biperiodization of ! aux.fields ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ELTDIR_CTL - control of Legendre transform ! EFTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti: 01-03-13 adaptation to aladin ! P. Smolikova 02-09-30 : AUX_PROC for d4 in NH ! Y. Seity and G. Radnoti : 03-09-29 : phasing for AL27 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Bogatchev 19-04-2013 Comparison of ubound(pspdiv,1) ! with ubound(pspvor,1) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EDIR_TRANS_CTL_MOD ,ONLY : EDIR_TRANS_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !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(:,:) 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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) 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(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANV(:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EDIR_TRANS',0,ZHOOK_HANDLE) CALL GSTATS(1808,0) CALL ESET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT ! This is for use in TRGTOL which is shared with adjoint inverse transform LSCDERS=.FALSE. LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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 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,*) 'DIR_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANS : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= UBOUND(PSPVOR,1)) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_TRANS: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,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1808,1) ! ------------------------------------------------------------------ CALL EDIR_TRANS_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV,AUX_PROC) IF (LHOOK) CALL DR_HOOK('EDIR_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EDIR_TRANS ectrans-1.8.0/src/etrans/gpu/external/etrans_release.F900000664000175000017500000000173215174631767023343 0ustar alastairalastairSUBROUTINE ETRANS_RELEASE(KRESOL) !**** *ETRANS_RELEASE* - release a spectral resolution ! Purpose. ! -------- ! Release all arrays related to a given resolution tag !** Interface. ! ---------- ! CALL ETRANS_RELEASE ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM !ifndef INTERFACE USE EDEALLOC_RESOL_MOD ,ONLY : EDEALLOC_RESOL ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL !endif INTERFACE ! ------------------------------------------------------------------ CALL EDEALLOC_RESOL(KRESOL) ! ------------------------------------------------------------------ END SUBROUTINE ETRANS_RELEASE ectrans-1.8.0/src/etrans/gpu/external/etrans_inq.F900000664000175000017500000004275515174631767022524 0ustar alastairalastairSUBROUTINE ETRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& & KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& & KMYMS,KESM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& & KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& & KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& & KULTPP,KPTRLS,& & KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& & LDSPLITLAT,LDLINEAR_GRID,& & KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,KDEF_RESOL,LDLAM,& & PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KCPL2M,KCPL4M ,KPROCM) !**** *ETRANS_INQ* - Extract information from the transform package ! Purpose. ! -------- ! Interface routine for extracting information from the T.P. !** Interface. ! ---------- ! CALL ETRANS_INQ(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resolution (input) ! MULTI-TRANSFORMS MANAGEMENT ! KDEF_RESOL - number or resolutions defined ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! SPECTRAL SPACE ! KSPEC - number of complex spectral coefficients on this PE ! KSPEC2 - 2*KSPEC ! KSPEC2G - global KSPEC2 ! KSPEC2MX - maximun KSPEC2 among all PEs ! KNUMP - Number of spectral waves handled by this PE ! KGPTOT - Total number of grid columns on this PE ! KGPTOTG - Total number of grid columns on the Globe ! KGPTOTMX - Maximum number of grid columns on any of the PEs ! KGPTOTL - Number of grid columns one each PE (dimension ! N_REGIONS_NS:N_REGIONS_EW) ! KMYMS - This PEs spectral zonal wavenumbers ! KESM0 - Address in a spectral array of (m, n=m) ! KUMPP - No. of wave numbers each wave set is responsible for ! KPOSSP - Defines partitioning of global spectral fields among PEs ! KPTRMS - Pointer to the first wave number of a given a-set ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KSMAX - spectral truncation - n direction ! KMSMAX - spectral truncation - m direction ! KNVALUE - n value for each KSPEC2 spectral coeffient ! KMVALUE - m value for each KSPEC2 spectral coeffient ! LDLINEAR_GRID : .TRUE. if the grid is linear ! GRIDPOINT SPACE ! KFRSTLAT - First latitude of each a-set in grid-point space ! KLSTTLAT - Last latitude of each a-set in grid-point space ! KFRSTLOFF - Offset for first lat of own a-set in grid-point space ! KPTRLAT - Pointer to the start of each latitude ! KPTRFRSTLAT - Pointer to the first latitude of each a-set in ! NSTA and NONL arrays ! KPTRLSTLAT - Pointer to the last latitude of each a-set in ! NSTA and NONL arrays ! KPTRFLOFF - Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 ! KSTA - Position of first grid column for the latitudes on a ! processor. The information is available for all processors. ! The b-sets are distinguished by the last dimension of ! nsta().The latitude band for each a-set is addressed by ! nptrfrstlat(jaset),nptrlstlat(jaset), and ! nptrfloff=nptrfrstlat(myseta) on this processors a-set. ! Each split latitude has two entries in nsta(,:) which ! necessitates the rather complex addressing of nsta(,:) ! and the overdimensioning of nsta by N_REGIONS_NS. ! KONL - Number of grid columns for the latitudes on a processor. ! Similar to nsta() in data structure. ! LDSPLITLAT - TRUE if latitude is split in grid point space over ! two a-sets ! FOURIER SPACE ! KULTPP - number of latitudes for which each a-set is calculating ! the FFT's. ! KPTRLS - pointer to first global latitude of each a-set for which ! it performs the Fourier calculations ! LEGENDRE ! PMU - sin(Gaussian latitudes) ! PGW - Gaussian weights ! PRPNM - Legendre polynomials ! KLEI3 - First dimension of Legendre polynomials ! KSPOLEGL - Second dimension of Legendre polynomials ! KPMS - Adress for legendre polynomial for given M (NSMAX) ! PLEPINM - Eigen-values of the inverse Laplace operator ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing with TFL 36R4 ! R. El Khatib 08-Aug-2012 KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,LDLAM,KDEF_RESOL,LDLINEAR_GRID ! T. Dalkilic 28-Aug-2012 KCPL4M ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NDEF_RESOL USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRNS, NPRTRW, MYSETV, MYSETW USE TPMALD_DIM ,ONLY : RALD USE TPMALD_DISTR ,ONLY : DALD USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F USE TPMALD_FIELDS USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & & N_REGIONS_EW, N_REGIONS_NS USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2 INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2G INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2MX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KNUMP INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOT INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTG INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTMX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTL(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KMYMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KESM0(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KUMPP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPOSSP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KALLMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KDIM0G(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLOFF INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFLOFF INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSTA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KONL(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KULTPP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW LOGICAL ,OPTIONAL,INTENT(INOUT) :: LDSPLITLAT(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMU(:) REAL(KIND=JPRB) ,OPTIONAL :: PGW(:) ! Argument NOT used REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PRPNM(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLEI3 INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPOLEGL INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPMS(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL2M(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL4M(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPROCM(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMVALUE(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PLEPINM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLINEAR_GRID !ifndef INTERFACE INTEGER(KIND=JPIM) :: IU1,IU2 INTEGER(KIND=JPIM) :: IC, JN, JMLOC, IM, JJ, JM INTEGER(KIND=JPIM) :: ISMAX(0:R%NSMAX),ISNAX(0:RALD%NMSMAX),ICPLM(0:RALD%NMSMAX) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('ETRANS_INQ',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) IF(PRESENT(KSPEC)) KSPEC = D%NSPEC IF(PRESENT(KSPEC2)) KSPEC2 = D%NSPEC2 IF(PRESENT(KSPEC2G)) KSPEC2G = R%NSPEC2_G IF(PRESENT(KSPEC2MX)) KSPEC2MX = D%NSPEC2MX IF(PRESENT(KNUMP)) KNUMP = D%NUMP IF(PRESENT(KGPTOT)) KGPTOT = D%NGPTOT IF(PRESENT(KGPTOTG)) KGPTOTG = D%NGPTOTG IF(PRESENT(KGPTOTMX)) KGPTOTMX = D%NGPTOTMX IF(PRESENT(KFRSTLOFF)) KFRSTLOFF = D%NFRSTLOFF IF(PRESENT(KPTRFLOFF)) KPTRFLOFF = D%NPTRFLOFF IF(PRESENT(KPRTRW)) KPRTRW = NPRTRW IF(PRESENT(KMYSETW)) KMYSETW = MYSETW IF(PRESENT(KMYSETV)) KMYSETV = MYSETV IF(PRESENT(KMY_REGION_NS)) KMY_REGION_NS = MY_REGION_NS IF(PRESENT(KMY_REGION_EW)) KMY_REGION_EW = MY_REGION_EW IF(PRESENT(LDLAM)) LDLAM = G%LAM IF(PRESENT(KDEF_RESOL)) KDEF_RESOL = NDEF_RESOL IF(PRESENT(KGPTOTL)) THEN IF(UBOUND(KGPTOTL,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KGPTOTL DIM 1 TOO SMALL') ELSEIF(UBOUND(KGPTOTL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('ETRANS_INQ: KGPTOTL DIM 2 TOO SMALL') ELSE KGPTOTL(1:N_REGIONS_NS,1:N_REGIONS_EW) = D%NGPTOTL(:,:) ENDIF ENDIF IF(PRESENT(KMYMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KMYMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KMYMS,1) < D%NUMP) THEN CALL ABORT_TRANS('ETRANS_INQ: KMYMS TOO SMALL') ELSE KMYMS(1:D%NUMP) = D%MYMS(:) ENDIF ENDIF IF(PRESENT(KESM0)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KESM0 REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KESM0,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KESM0 TOO SMALL') ELSE KESM0(0:RALD%NMSMAX) = DALD%NESM0(:) ENDIF ENDIF IF(PRESENT(KCPL2M)) THEN IF(UBOUND(KCPL2M,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KCPL2M TOO SMALL') ELSE KCPL2M(0:RALD%NMSMAX) = DALD%NCPL2M(:) ENDIF ENDIF IF(PRESENT(KPROCM)) THEN IF(UBOUND(KPROCM,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KPROCM TOO SMALL') ELSE KPROCM(0:RALD%NMSMAX) = D%NPROCM(:) ENDIF ENDIF IF(PRESENT(KUMPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KUMPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KUMPP,1) < NPRTRW) THEN CALL ABORT_TRANS('ETRANS_INQ: KUMPP TOO SMALL') ELSE KUMPP(1:NPRTRW) = D%NUMPP(:) ENDIF ENDIF IF(PRESENT(KPOSSP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPOSSP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPOSSP,1) < NPRTRW+1) THEN CALL ABORT_TRANS('ETRANS_INQ: KPOSSP TOO SMALL') ELSE KPOSSP(1:NPRTRW+1) = D%NPOSSP(:) ENDIF ENDIF IF(PRESENT(KPTRMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRMS,1) < NPRTRW) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRMS TOO SMALL') ELSE KPTRMS(1:NPRTRW) = D%NPTRMS(:) ENDIF ENDIF IF(PRESENT(KALLMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KALLMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KALLMS,1) < RALD%NMSMAX+1) THEN CALL ABORT_TRANS('ETRANS_INQ: KALLMS TOO SMALL') ELSE KALLMS(1:RALD%NMSMAX+1) = D%NALLMS(:) ENDIF ENDIF IF(PRESENT(KDIM0G)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KDIM0G REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KDIM0G,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KDIM0G TOO SMALL') ELSE KDIM0G(0:RALD%NMSMAX) = D%NDIM0G(0:RALD%NMSMAX) ENDIF ENDIF IF(PRESENT(KFRSTLAT)) THEN IF(UBOUND(KFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KFRSTLAT TOO SMALL') ELSE KFRSTLAT(1:N_REGIONS_NS) = D%NFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KLSTLAT)) THEN IF(UBOUND(KLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KLSTLAT TOO SMALL') ELSE KLSTLAT(1:N_REGIONS_NS) = D%NLSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLAT)) THEN IF(UBOUND(KPTRLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLAT TOO SMALL') ELSE KPTRLAT(1:R%NDGL) = D%NPTRLAT(:) ENDIF ENDIF IF(PRESENT(KPTRFRSTLAT)) THEN IF(UBOUND(KPTRFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRFRSTLAT TOO SMALL') ELSE KPTRFRSTLAT(1:N_REGIONS_NS) = D%NPTRFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLSTLAT)) THEN IF(UBOUND(KPTRLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLSTLAT TOO SMALL') ELSE KPTRLSTLAT(1:N_REGIONS_NS) = D%NPTRLSTLAT(:) ENDIF ENDIF IF(PRESENT(KSTA)) THEN IF(UBOUND(KSTA,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('ETRANS_INQ: KSTA DIM 1 TOO SMALL') ELSEIF(UBOUND(KSTA,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('ETRANS_INQ: KSTA DIM 2 TOO SMALL') ELSE KSTA(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NSTA(:,:) ENDIF ENDIF IF(PRESENT(KONL)) THEN IF(UBOUND(KONL,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('ETRANS_INQ: KONL DIM 1 TOO SMALL') ELSEIF(UBOUND(KONL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('ETRANS_INQ: KONL DIM 2 TOO SMALL') ELSE KONL(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NONL(:,:) ENDIF ENDIF IF(PRESENT(LDSPLITLAT)) THEN IF(UBOUND(LDSPLITLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('ETRANS_INQ: LDSPLITLAT TOO SMALL') ELSE LDSPLITLAT(1:R%NDGL) = D%LSPLITLAT(:) ENDIF ENDIF IF(PRESENT(KULTPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KULTPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KULTPP,1) < NPRTRNS) THEN CALL ABORT_TRANS('ETRANS_INQ: KULTPP TOO SMALL') ELSE KULTPP(1:NPRTRNS) = D%NULTPP(:) ENDIF ENDIF IF(PRESENT(KPTRLS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRLS,1) < NPRTRNS) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLS TOO SMALL') ELSE KPTRLS(1:NPRTRNS) = D%NPTRLS(:) ENDIF ENDIF IF(PRESENT(PMU)) THEN IF(UBOUND(PMU,1) < R%NDGL) THEN CALL ABORT_TRANS('ETRANS_INQ: PMU TOO SMALL') ELSE PMU(1:R%NDGL) = F%RMU ENDIF ENDIF IF(PRESENT(PRPNM)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: PRPNM REQUIRED BUT LGRIDONLY=T') ENDIF IU1 = UBOUND(PRPNM,1) IU2 = UBOUND(PRPNM,2) IF(IU1 < R%NDGNH) THEN CALL ABORT_TRANS('ETRANS_INQ:FIRST DIM. OF PRNM TOO SMALL') ELSE IU1 = MIN(IU1,R%NLEI3) IU2 = MIN(IU2,D%NSPOLEGL) PRPNM(1:IU1,1:IU2) = F%RPNM(1:IU1,1:IU2) ENDIF ENDIF IF(PRESENT(KLEI3)) THEN KLEI3=R%NLEI3 ENDIF IF(PRESENT(KSPOLEGL)) THEN KSPOLEGL=D%NSPOLEGL ENDIF IF(PRESENT(KPMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPMS,1) < R%NSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KPMS TOO SMALL') ELSE KPMS(0:R%NSMAX) = D%NPMS(0:R%NSMAX) ENDIF ENDIF IF(PRESENT(KSMAX)) KSMAX = R%NSMAX IF(PRESENT(KMSMAX)) KMSMAX = RALD%NMSMAX IF(PRESENT(PLEPINM)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: PLEPINM REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(PLEPINM,1) < R%NSPEC_G/2) THEN CALL ABORT_TRANS('ETRANS_INQ: PLEPINM TOO SMALL') ELSEIF (LBOUND(PLEPINM,1) /= -1) THEN CALL ABORT_TRANS('ETRANS_INQ: LOWER BOUND OF PLEPINM SHOULD BE -1') ELSE PLEPINM(:) = FALD%RLEPINM(:) ENDIF ENDIF IF(PRESENT(KNVALUE)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') ENDIF IF(SIZE(KNVALUE) < D%NSPEC2) THEN CALL ABORT_TRANS('ETRANS_INQ: KNVALUE TOO SMALL') ELSE CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) DO JM=0,RALD%NMSMAX ICPLM(JM) = 1*(ISNAX(JM)+1) ENDDO IC=1 DO JMLOC=1,D%NUMP IM=D%MYMS(JMLOC) DO JN=0,ICPLM(IM)-1 DO JJ=0,3 KNVALUE(IC+JJ)=JN ENDDO IC=IC+4 ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KMVALUE)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') ENDIF IF(SIZE(KMVALUE) < D%NSPEC2) THEN CALL ABORT_TRANS('ETRANS_INQ: KMVALUE TOO SMALL') ELSE CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) DO JM=0,RALD%NMSMAX ICPLM(JM) = 1*(ISNAX(JM)+1) ENDDO IC=1 DO JMLOC=1,D%NUMP IM=D%MYMS(JMLOC) DO JN=0,ICPLM(IM)-1 DO JJ=0,3 KMVALUE(IC+JJ)=IM ENDDO IC=IC+4 ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KCPL4M)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KCPL4M REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KCPL4M,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KCPL4M TOO SMALL') ELSE CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) DO JM=0,RALD%NMSMAX KCPL4M(JM) = 4*(ISNAX(JM)+1) ENDDO ENDIF ENDIF IF(PRESENT(LDLINEAR_GRID)) THEN LDLINEAR_GRID = R%NSMAX > (R%NDGL -1)/3 .OR. RALD%NMSMAX > (R%NDLON -1)/3 ENDIF IF (LHOOK) CALL DR_HOOK('ETRANS_INQ',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE ETRANS_INQ ectrans-1.8.0/src/etrans/gpu/external/egpnorm_trans.F900000664000175000017500000000506415174631767023227 0ustar alastairalastairSUBROUTINE EGPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !**** *EGPNORM_TRANS* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL EGPNORM_TRANS(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! Modifications. ! -------------- ! Original : 19th Sept 2008 ! R. El Khatib 07-08-2009 Optimisation directive for NEC ! R. El Khatib 16-Sep-2019 merge with global model code ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL ,INTENT(IN) :: LDAVE_ONLY INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EGPNORM_TRANS',0,ZHOOK_HANDLE) ! Set current resolution CALL ESET_RESOL(KRESOL) CALL GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY) ! note: weighting not taken into account by GPNORM_TRANS, so we do it here PAVE=PAVE/G%NLOEN(1) IF (LHOOK) CALL DR_HOOK('EGPNORM_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EGPNORM_TRANS ectrans-1.8.0/src/etrans/gpu/external/edir_transad.F900000664000175000017500000004453015174631767023011 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EDIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) !**** *EDIR_TRANSAD* - Direct spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the direct spectral transform - adjoint !** Interface. ! ---------- ! CALL EDIR_TRANSAD(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 (input) ! 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): ! 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) ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- EDIR_TRANS_CTLAD - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV USE ESET_RESOL_MOD ,ONLY : ESET_RESOL !USE EDIR_TRANS_CTLAD_MOD ,ONLY : EDIR_TRANS_CTLAD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) 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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANV(:) !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EDIR_TRANSAD',0,ZHOOK_HANDLE) CALL ABORT_TRANS('Adjoint code of ectrans/lam not implemented on GPU yet') #ifdef UNDEF CALL GSTATS(1810,0) ! Set current resolution CALL ESET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT LSCDERS=.FALSE. ! This is for use in TRLTOG which is shared with inverse transform LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANSAD:KVSETUV 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 ENDIF IF(PRESENT(KVSETSC)) THEN IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC 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('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& & UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= IF_UV) THEN WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& & UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANSAD : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_TRANS: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,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1810,1) ! Perform transform CALL EDIR_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV) ! ------------------------------------------------------------------ #endif !endif INTERFACE IF (LHOOK) CALL DR_HOOK('EDIR_TRANSAD',1,ZHOOK_HANDLE) END SUBROUTINE EDIR_TRANSAD ectrans-1.8.0/src/etrans/gpu/external/edist_spec.F900000664000175000017500000001266315174631767022476 0ustar alastairalastairSUBROUTINE EDIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& & LDIM1_IS_FLD,KSORT) !**** *EDIST_SPEC* - Distribute global spectral array among processors ! Purpose. ! -------- ! Interface routine for distributing spectral array !** Interface. ! ---------- ! CALL EDIST__SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PSPEC(:,:) - Local spectral array ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- DIST_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! P.Marguinaud 10-Oct-2014 Add KSORT argument (change the order of fields) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC USE TPMALD_DISTR ,ONLY : DALD USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE DIST_SPEC_CONTROL_MOD ,ONLY : DIST_SPEC_CONTROL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM),INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL LOGICAL ,OPTIONAL,INTENT(IN) :: LDIM1_IS_FLD REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFDISTG) INTEGER(KIND=JPIM) :: IFSEND,IFRECV,J, IFLD, ICOEFF INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G, ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) LLDIM1_IS_FLD=.TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD=LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD=1 ICOEFF=2 ELSE IFLD=2 ICOEFF=1 ENDIF ISMAX = RALD%NMSMAX ALLOCATE(IDIM0G(0:ISMAX)) ALLOCATE(IALLMS(ISMAX+1)) ALLOCATE(IKN(0:ISMAX)) ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ISPEC2MX = D%NSPEC2MX IUMPP(:) = D%NUMPP(:) IALLMS(:) = D%NALLMS(:) IPTRMS(:) = D%NPTRMS(:) DO J=0,ISMAX IKN(J)=2*DALD%NCPL2M(J) ENDDO IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('EDIST_SPEC: KFROM TOO SHORT!') ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'EDIST_SPEC:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('EDIST_SPEC:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('EDIST_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFSEND) THEN WRITE(NERR,*)'EDIST_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFSEND CALL ABORT_TRANS('EDIST_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*)'EDIST_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('EDIST_SPEC: COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFDISTG) THEN CALL ABORT_TRANS('EDIST_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFDISTG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'EDIST_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('EDIST_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFRECV = IFRECV+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFDISTG) ELSE IFRECV = KFDISTG IVSET(:) = MYSETV ENDIF IF(IFRECV > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('EDIST_SPEC: FIELDS TO RECEIVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFRECV) THEN CALL ABORT_TRANS('EDIST_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('EDIST_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (.NOT. PRESENT (PSPEC)) THEN CALL ABORT_TRANS('EDIST_SPEC: KSORT REQUIRES PSPEC') ENDIF IF (UBOUND (KSORT, 1) /= UBOUND (PSPEC, IFLD)) THEN CALL ABORT_TRANS('EDIST_SPEC: DIMENSION MISMATCH KSORT, PSPEC') ENDIF ENDIF CALL DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,IVSET,PSPEC,LLDIM1_IS_FLD,& & ISMAX,ISPEC2,ISPEC2_G,IPOSSP,IDIM0G,KSORT) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EDIST_SPEC ectrans-1.8.0/src/etrans/gpu/external/egath_spec.F900000664000175000017500000001363215174631767022453 0ustar alastairalastairSUBROUTINE EGATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,KMSMAX,LDZA0IP) !**** *EGATH_SPEC* - Gather global spectral array from processors ! Purpose. ! -------- ! Interface routine for gathering spectral array !** Interface. ! ---------- ! CALL EGATH_SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for gathering each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PSPEC(:,:) - Local spectral array ! LDZA0IP - Set to zero imaginary part of first coefficients ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! Modified 03-09-30 Y. Seity, bug correction IFSEND=0 ! R. El Khatib 23-Oct-2012 Monkey business ! P.Marguinaud 10-Oct-2013 Add an option to set (or not) first ! coefficients imaginary part to zero ! R. El Khatib 01-Dec-2020 Merge egath_spec_control and gath_spec_control ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC USE TPMALD_DISTR USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE GATH_SPEC_CONTROL_MOD ,ONLY : GATH_SPEC_CONTROL 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) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMSMAX LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFGATHG) INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J INTEGER(KIND=JPIM) :: IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, IMSMAX, ISPEC2, ISPEC2_G,ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL ESET_RESOL(KRESOL) LLDIM1_IS_FLD = .TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD = 1 ICOEFF = 2 ELSE IFLD = 2 ICOEFF = 1 ENDIF IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('EGATH_SPEC: KTO TOO SHORT!') ENDIF ISMAX = R%NSMAX IMSMAX = RALD%NMSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX IF(PRESENT(KMSMAX)) IMSMAX = KMSMAX ALLOCATE(IDIM0G(0:IMSMAX)) ALLOCATE(IALLMS(IMSMAX+1)) ALLOCATE(IKN(0:IMSMAX)) IF(IMSMAX /= RALD%NMSMAX .OR. ISMAX /= R%NSMAX) THEN CALL ABORT_TRANS('EGATH_SPEC:TRUNCATION CHANGE NOT YET CODED') ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ISPEC2MX = D%NSPEC2MX IUMPP(:) = D%NUMPP(:) IALLMS(:) = D%NALLMS(:) IPTRMS(:) = D%NPTRMS(:) DO J=0,IMSMAX IKN(J)=2*DALD%NCPL2M(J) ENDDO ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'EGATH_SPEC:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('EGATH_SPEC:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('EGATH_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFRECV) THEN WRITE(NERR,*) 'EGATH_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFRECV CALL ABORT_TRANS('EGATH_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'EGATH_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('EGATH_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFGATHG) THEN CALL ABORT_TRANS('EGATH_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFGATHG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'EGATH_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('EGATH_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFSEND = IFSEND+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFGATHG) ELSEIF(NPRTRV > 1) THEN WRITE(NERR,*) 'EGATH_SPEC:KVSET MISSING, NPRTRV ',NPRTRV CALL ABORT_TRANS('EGATH_SPEC:KVSET MISSING, NPRTRV > 1') ELSE IFSEND = KFGATHG IVSET(:) = 1 ENDIF IF(IFSEND > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('EGATH_SPEC: FIELDS TO RECIEVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFSEND) THEN CALL ABORT_TRANS('EGATH_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('EGATH_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,& & IMSMAX,ISPEC2,ISPEC2_G,IPOSSP,IDIM0G,LDZA0IP) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EGATH_SPEC ectrans-1.8.0/src/etrans/gpu/external/edist_grid.F900000664000175000017500000000755015174631767022470 0ustar alastairalastairSUBROUTINE EDIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) !**** *EDIST_GRID* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL EDIST_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:) - Local spectral array ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- DIST_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! P.Marguinaud 10-Oct-2014 Add KSORT argument ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE DIST_GRID_CTL_MOD ,ONLY : DIST_GRID_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EDIST_GRID',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('EDIST_GRID: KFROM TOO SHORT!') ENDIF IFSEND = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'EDIST_GRID:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('EDIST_GRID:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'EDIST_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFDISTG) THEN WRITE(NOUT,*)'EDIST_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFDISTG CALL ABORT_TRANS('EDIST_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'EDIST_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('EDIST_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('EDIST_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFSEND) THEN CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (UBOUND (KSORT, 1) /= UBOUND (PGP, 2)) THEN CALL ABORT_TRANS('EDIST_GRID: DIMENSION MISMATCH KSORT, PGP') ENDIF ENDIF CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP,KSORT) IF (LHOOK) CALL DR_HOOK('EDIST_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EDIST_GRID ectrans-1.8.0/src/etrans/gpu/external/especnorm.F900000664000175000017500000000676115174631767022351 0ustar alastairalastairSUBROUTINE ESPECNORM(PSPEC,KVSET,KMASTER,KRESOL,PMET,PNORM) !**** *ESPECNORM* - Compute global spectral norms ! Purpose. ! -------- ! Interface routine for computing spectral norms !** Interface. ! ---------- ! CALL ESPECNORM(...) ! Explicit arguments : All arguments optional ! -------------------- ! PSPEC(:,:) - Spectral array ! KVSET(:) - "B-Set" for each field ! KMASTER - processor to recieve norms ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PMET(:) - metric ! PNORM(:) - Norms (output for processor KMASTER) ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ESPNORM_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV, MYPROC USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE ESPNORM_CTL_MOD ,ONLY : ESPNORM_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KMASTER INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMET(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PNORM(:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IMASTER,IFLD,IFLD_G,J REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('ESPECNORM',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) ! Set defaults IMASTER = 1 IFLD = 0 IF(PRESENT(KMASTER)) THEN IMASTER = KMASTER ENDIF IF(PRESENT(KVSET)) THEN IFLD_G = UBOUND(KVSET,1) DO J=1,IFLD_G IF(KVSET(J) > NPRTRV) THEN WRITE(NERR,*) 'ESPECNORM:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('ESPECNORM:KVSET TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFLD = IFLD+1 ENDIF ENDDO ELSE IF(PRESENT(PSPEC)) THEN IFLD = UBOUND(PSPEC,1) ENDIF IFLD_G = IFLD ENDIF IF(NPRTRV >1) THEN IF(IFLD > 0 .AND. .NOT. PRESENT(KVSET)) THEN WRITE(NERR,*)'NPRTRV >1 AND IFLD > 0 AND NOT PRESENT(KVSET)',& & NPRTRV,IFLD CALL ABORT_TRANS('ESPECNORM: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(MYPROC == IMASTER) THEN IF(.NOT. PRESENT(PNORM)) THEN CALL ABORT_TRANS('ESPECNORM: PNORM NOT PRESENT') ENDIF IF(UBOUND(PNORM,1) < IFLD_G) THEN CALL ABORT_TRANS('ESPECNORM: PNORM TOO SMALL') ENDIF ENDIF IF(IFLD > 0 ) THEN IF(.NOT. PRESENT(PSPEC)) THEN CALL ABORT_TRANS('ESPECNORM: PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,1) < IFLD) THEN CALL ABORT_TRANS('ESPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,2) < D%NSPEC2) THEN CALL ABORT_TRANS('ESPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL ESPNORM_CTL(PSPEC,IFLD,IFLD_G,KVSET,IMASTER,PMET,PNORM) IF (LHOOK) CALL DR_HOOK('ESPECNORM',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE ESPECNORM ectrans-1.8.0/src/etrans/gpu/CMakeLists.txt0000664000175000017500000001450615174631767021010 0ustar alastairalastairset( GPU_LIBRARY_TYPE SHARED ) if( HAVE_GPU_STATIC ) set( GPU_LIBRARY_TYPE STATIC ) endif() function(generate_backend_sources) set (options) set (oneValueArgs BACKEND DESTINATION OUTPUT) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(backend ${_PAR_BACKEND}) set(destination ${_PAR_DESTINATION}) file(MAKE_DIRECTORY ${destination}/internal) file(MAKE_DIRECTORY ${destination}/external) file(MAKE_DIRECTORY ${destination}/biper/external) file(MAKE_DIRECTORY ${destination}/biper/internal) ecbuild_list_add_pattern( LIST files GLOB internal/*.F90 external/*.F90 biper/internal/*.F90 biper/external/*.F90 QUIET ) set(outfiles) foreach(file_i ${files}) get_filename_component(outfile_name ${file_i} NAME) get_filename_component(outfile_name_we ${file_i} NAME_WE) get_filename_component(outfile_ext ${file_i} EXT) get_filename_component(outfile_dir ${file_i} DIRECTORY) set(outfile "${destination}/${file_i}") ecbuild_debug("Generate ${outfile}") generate_file(BACKEND ${backend} INPUT ${CMAKE_CURRENT_SOURCE_DIR}/${file_i} OUTPUT ${outfile}) list(APPEND outfiles ${outfile}) endforeach(file_i) set(${_PAR_OUTPUT} ${outfiles} PARENT_SCOPE) endfunction(generate_backend_sources) set( BUILD_INTERFACE_INCLUDE_DIR ${CMAKE_BINARY_DIR}/include/ectrans ) foreach( prec dp sp ) if( HAVE_${prec} ) set(GENERATED_SOURCE_DIR ${CMAKE_CURRENT_BINARY_DIR}/generated/ectrans_lam_gpu_${prec}) generate_backend_includes(BACKEND gpu_${prec} TARGET ectrans_lam_gpu_${prec}_includes DESTINATION ${BUILD_INTERFACE_INCLUDE_DIR} INCLUDE_DIRECTORY ${PROJECT_SOURCE_DIR}/src/etrans/include ) generate_backend_sources( BACKEND gpu_${prec} OUTPUT ectrans_lam_gpu_${prec}_src DESTINATION ${GENERATED_SOURCE_DIR}) # set custom compilation flags here: keeping as placeholder #if( NOT ${CMAKE_BUILD_TYPE_CAPS} STREQUAL DEBUG ) #set_source_files_properties( ${GENERATED_SOURCE_DIR}/internal/ftinv_mod.F90 PROPERTIES COMPILE_OPTIONS "-O2" ) #ecbuild_info("warn: special compile flags ftinv_mod.F90") #set_source_files_properties( ${GENERATED_SOURCE_DIR}/internal/ftdir_mod.F90 PROPERTIES COMPILE_OPTIONS "-O2" ) #ecbuild_info("warn: special compile flags ftdir_mod.F90") #endif() ecbuild_add_library( TARGET ectrans_lam_gpu_${prec} TYPE ${GPU_LIBRARY_TYPE} SOURCES ${ectrans_lam_gpu_${prec}_src} LINKER_LANGUAGE Fortran PUBLIC_INCLUDES $ $ $ $ PUBLIC_LIBS fiat ectrans_common ectrans_gpu_common ectrans_gpu_${prec} ectrans_gpu_${prec}_includes ectrans_lam_common ectrans_lam_gpu_${prec}_includes PRIVATE_LIBS ${ECTRANS_GPU_HIP_LIBRARIES} $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> $<${HAVE_OMP}:OpenMP::OpenMP_Fortran> $<${HAVE_MPI}:MPI::MPI_Fortran> PRIVATE_DEFINITIONS ${GPU_RUNTIME}GPU ${GPU_OFFLOAD}GPU #$<${HAVE_CUTLASS}:USE_CUTLASS> # not relevant for LAM #$<${HAVE_CUTLASS_3XTF32}:USE_CUTLASS_3XTF32> # not relevant for LAM #$<${HAVE_GPU_GRAPHS_GEMM}:USE_GRAPHS_GEMM> # not relevant for LAM $<${HAVE_GPU_GRAPHS_FFT}:USE_GRAPHS_FFT> #$<${HAVE_GPU_AWARE_MPI}:USE_GPU_AWARE_MPI> # not relevant for LAM #ECTRANS_HAVE_MPI=${ectrans_HAVE_MPI} # not relevant for LAM ) ecbuild_target_fortran_module_directory( TARGET ectrans_lam_gpu_${prec} MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/ectrans INSTALL_MODULE_DIRECTORY module/ectrans ) if( prec STREQUAL sp ) target_compile_definitions( ectrans_lam_gpu_${prec} PRIVATE TRANS_SINGLE PARKINDTRANS_SINGLE ) endif() # cuFFT can do in-place FFT, hipFFT cannot if( HAVE_CUDA ) target_compile_definitions( ectrans_lam_gpu_${prec} PRIVATE IN_PLACE_FFT ) endif() if( HAVE_OMP AND CMAKE_Fortran_COMPILER_ID MATCHES Cray ) # Propagate flags as link options for downstream targets. Only required for Cray target_link_options( ectrans_lam_gpu_${prec} INTERFACE $<$:SHELL:${OpenMP_Fortran_FLAGS}> $<$:SHELL:${OpenMP_Fortran_FLAGS}> $<$:SHELL:${OpenMP_Fortran_FLAGS}> ) endif() if( HAVE_ACC AND CMAKE_Fortran_COMPILER_ID MATCHES NVHPC ) # Propagate flags as link options for downstream targets. Only required for NVHPC target_link_options( ectrans_lam_gpu_${prec} INTERFACE $<$:SHELL:${OpenACC_Fortran_FLAGS}> $<$:SHELL:${OpenACC_Fortran_FLAGS}> $<$:SHELL:${OpenACC_Fortran_FLAGS}> ) endif() # This interface library is for backward compatibility, and provides the older includes ecbuild_add_library( TARGET etrans_gpu_${prec} TYPE INTERFACE ) target_include_directories( etrans_gpu_${prec} INTERFACE $ ) target_include_directories( etrans_gpu_${prec} INTERFACE $ ) target_link_libraries( etrans_gpu_${prec} INTERFACE ectrans_lam_gpu_${prec}) # ## Install trans_gpu_${prec} interface # file( GLOB trans_interface ${PROJECT_SOURCE_DIR}/src/trans/include/ectrans/* ) # install( # FILES ${trans_interface} # DESTINATION include/ectrans/trans_gpu_${prec} # ) endif() endforeach() ## Install etrans interface install( DIRECTORY ${BUILD_INTERFACE_INCLUDE_DIR}/ DESTINATION include/ectrans ) ectrans-1.8.0/src/etrans/gpu/biper/0000775000175000017500000000000015174631767017343 5ustar alastairalastairectrans-1.8.0/src/etrans/gpu/biper/internal/0000775000175000017500000000000015174631767021157 5ustar alastairalastairectrans-1.8.0/src/etrans/gpu/biper/internal/extper_mod.F900000664000175000017500000001044215174631767023606 0ustar alastairalastairMODULE EXTPER_MOD CONTAINS SUBROUTINE EXTPER(PWORK,KDIM,KPSTA,KPOINTS,KFLDS,KUNITS,& & KPOINTERS,KALFA) ! purpose : ! -------- ! Make spline extension. ! *CALL* *EXTPER(PWORK,KDIM,KPSTA,KPOINTS,KFLDS,KUNITS,& ! & KPOINTERS,KALFA) ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! PWORK : Input: values in C U I area ! : Output: input+(spline extension on the E area) ! KDIM : Dimension of the C U I U E unit of work (one row or one m) ! KPSTA : Position where the unit of work starts ! KPOINTS : Position where the unit of work ends ! KFLDS : number of 2D fields ! KUNITS : Number of units of work ! KPOINTERS : Array of pointers for the units of work ! KALFA : boundary condition of a spline: ! = 0 ... natural spline ! = 1 ... boundary condition computed differentially ! (additional option) ! references : ! ---------- ! author : ! ------ ! M. Hortal 03-11-2009 ! ----------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN USE TPM_DISTR IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDIM INTEGER(KIND=JPIM),INTENT(IN) :: KPSTA INTEGER(KIND=JPIM),INTENT(IN) :: KPOINTS INTEGER(KIND=JPIM),INTENT(IN) :: KFLDS INTEGER(KIND=JPIM),INTENT(IN) :: KUNITS INTEGER(KIND=JPIM),INTENT(IN) :: KPOINTERS(:) INTEGER(KIND=JPIM),INTENT(IN) :: KALFA ! arrays : ! -------- INTEGER(KIND=JPIM) :: IENDX, IENDY, JFL, JLAT, JLON, IA REAL(KIND=JPRB) :: ZA, ZB, ZC, ZD, ZEPSA, ZEPSB, ZJ, ZK, ZKP1,& & ZLAM, ZLAMB, ZM1, ZM2, ZMM, ZNY REAL(KIND=JPRB) :: ZMAX(KUNITS), ZMIN(KUNITS) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ #include "abor1.intfb.h" ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EXTPER',0,ZHOOK_HANDLE) !* 0. Security ! -------- IF(UBOUND(PWORK,1) < KFLDS) THEN CALL ABOR1(' EXTPER, PWORK first dimension too small') ENDIF IF(UBOUND(PWORK,2) < KDIM+2) THEN WRITE(NOUT,*) ' UBOUND(PWORK,2)=',UBOUND(PWORK,2),' KDIM=',KDIM,' KUNITS=',& &KUNITS CALL ABOR1(' EXTPER, PWORK second dimension too small') ENDIF IF(UBOUND(KPOINTERS,1) < KUNITS) THEN CALL ABOR1(' EXTPER, KPOINTERS too small') ENDIF IF(UBOUND(PWORK,2) < KPOINTERS(KUNITS)+KDIM) THEN WRITE(NERR,*) ' EXTPER, KUNITS=',KUNITS,' KPOINTERS=',KPOINTERS(1:KUNITS),& &' KDIM=',KDIM,' UBOUND(PWORK,2)=',UBOUND(PWORK,2) CALL ABOR1(' EXTPER, value of KPOINTERS too large') ENDIF !* 1. Spline Extension. ! ------------------- DO JFL = 1, KFLDS ZK = REAL(KDIM-KPOINTS+1,JPRB) ZKP1 = ZK + 1.0_JPRB ZLAMB = ZK/ZKP1 ZNY = REAL(KALFA,JPRB)/ZKP1 DO JLAT=1,KUNITS ZEPSA = & &((PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK -& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS)+& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-1))*6._JPRB/ZKP1 -& & ZNY*(PWORK(JFL,KPOINTERS(JLAT)+KPOINTS)-& & 2.0_JPRB* PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-1)+& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-2)) ZEPSB = (PWORK(JFL,KPOINTERS(JLAT)+KPSTA+1)-& & PWORK(JFL,KPOINTERS(JLAT)+KPSTA) -& & (PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK)*6._JPRB/ZKP1-& & ZNY*(PWORK(JFL,KPOINTERS(JLAT)+KPSTA+2)-& & 2.0_JPRB* PWORK(JFL,KPOINTERS(JLAT)+KPSTA+1)+& & PWORK(JFL,KPOINTERS(JLAT)+KPSTA)) ZMM = 4._JPRB - ZLAMB*ZLAMB ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ZMM ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ZMM ZA = PWORK(JFL,KPOINTERS(JLAT)+KPOINTS) ZB = (PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK-& & (2.0_JPRB*ZM1 + ZM2) * ZK/6._JPRB ZC = 0.5_JPRB * ZM1 ZD = (ZM2 - ZM1)/(6._JPRB*ZK) DO JLON=KPOINTERS(JLAT)+KPOINTS+1,KPOINTERS(JLAT)+KDIM ZJ = REAL(JLON - (KPOINTERS(JLAT)+KPOINTS),JPRB) PWORK(JFL,JLON) = ZA + ZJ * (ZB + ZJ * (ZC + ZD * ZJ)) ENDDO ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EXTPER',1,ZHOOK_HANDLE) END SUBROUTINE EXTPER END MODULE EXTPER_MOD ectrans-1.8.0/src/etrans/gpu/biper/internal/espline_mod.F900000664000175000017500000001373015174631767023741 0ustar alastairalastairMODULE ESPLINE_MOD CONTAINS SUBROUTINE ESPLINE(KDLUN,KDLON,KDGUN,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM,KDGSA,KDGEN,KNUBI,PWORK,PALFA,LDBIX,LDBIY,KDAD) ! purpose : ! -------- ! Make spline extension. ! *CALL* *ESPLINE*(...) ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! KDLUN : lower bound for the x (or longitude) dimension ! of the gridpoint array ! KDLON : upper bound for the x (or longitude) dimension ! of the gridpoint array on C U I U E ! KDGUN : lower bound for the y (or latitude) dimension ! of the gridpoint array ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U E ! KDLUX : upper bound for the x (or longitude) dimension ! of C U I. ! KDGUX : upper bound for the y (or latitude) dimension ! of C U I. ! KSTART : first dimension in x direction of g-p array ! KDLSM : last dimension in x direction of g-p array ! KDGSA : first dimension in y of g-p array ! KDGEN : last dimension in y of g-p array ! KNUBI : number of levels to biperiodicise ! PWORK : gridpoint array on C U I U E. ! PALFA : boundary condition of a spline: ! = 0. ... natural spline ! = 1. ... boundary condition computed differentially ! (additional option) ! LDBIX : .TRUE. biperiodicisation in x ( and vice versa ) ! LDBIY : .TRUE. biperiodicisation in y ( and vice versa ) ! KDAD : 1 for test of biperiodic. ! references : ! ---------- ! author : ! ------ ! Michal Batka and Radmila Bubnova ( B & B ) ! modifications : ! ------------- ! J.Vivoda 03-2002 2D model fix ! A. Stanesic : 28-03-08: KDADD - test of externalized biper. ! ------------------------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK ! ------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KSTART INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA INTEGER(KIND=JPIM),INTENT(IN) :: KDGEN INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KDLUN INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGUN INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(KSTART:KDLSM,KNUBI,KDGSA:KDGEN) REAL(KIND=JPRB) ,INTENT(IN) :: PALFA LOGICAL ,INTENT(IN) :: LDBIX LOGICAL ,INTENT(IN) :: LDBIY INTEGER(KIND=JPIM),INTENT(IN) :: KDAD ! ------------------------------------------------------------- LOGICAL :: LLBIX LOGICAL :: LLBIY INTEGER(KIND=JPIM) :: IENDX, IENDY, JFL, JLAT, JLON, IA REAL(KIND=JPRB) :: ZA, ZB, ZC, ZD, ZEPSA, ZEPSB, ZJ, ZK, ZKP1,& & ZLAM, ZLAMB, ZM1, ZM2, ZMM, ZNY REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESPLINE',0,ZHOOK_HANDLE) ! ------------------------------------------------------------- !* 1. Spline Extension. ! ------------------- LLBIX=LDBIX LLBIY=LDBIY IF( KDLUN==1.AND.KDLUX==1 ) LLBIX=.FALSE. IF( KDGUN==1.AND.KDGUX==1 ) LLBIY=.FALSE. IENDX = KDGUX IENDY = KDLON IF(LLBIX.AND.(.NOT.LLBIY)) THEN IENDY = KDLUN - 1 ELSEIF((.NOT.LLBIX).AND.LLBIY) THEN IENDX = KDGUN - 1 IENDY = KDLUX ELSEIF((.NOT.LLBIX).AND.(.NOT.LLBIY)) THEN IF (LHOOK) CALL DR_HOOK('ESPLINE',1,ZHOOK_HANDLE) RETURN ENDIF DO JFL = 1, KNUBI ZK = REAL(KDLON-KDLUX+1,JPRB) ZKP1 = ZK + 1.0_JPRB ZLAMB = ZK/ZKP1 ZNY = PALFA/ZKP1 DO JLAT=KDGUN,IENDX ZEPSA = ((PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK -& & PWORK(KDLUX,JFL,JLAT)+PWORK(KDLUX-1,JFL,JLAT))*6._JPRB/ZKP1 -& & ZNY*(PWORK(KDLUX,JFL,JLAT)-2.0_JPRB* PWORK(KDLUX-1,JFL,JLAT)+& & PWORK(KDLUX-2,JFL,JLAT)) ZEPSB = (PWORK(KDLUN+1,JFL,JLAT)-PWORK(KDLUN,JFL,JLAT) -& & (PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK)*6._JPRB/ZKP1-& & ZNY*(PWORK(KDLUN+2,JFL,JLAT)-2.0_JPRB* PWORK(KDLUN+1,JFL,JLAT)+& & PWORK(KDLUN,JFL,JLAT)) ZMM = 4._JPRB - ZLAMB*ZLAMB ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ZMM ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ZMM ZA = PWORK(KDLUX,JFL,JLAT) ZB = (PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK-& & (2.0_JPRB*ZM1 + ZM2) * ZK/6._JPRB ZC = 0.5_JPRB * ZM1 ZD = (ZM2 - ZM1)/(6._JPRB*ZK) DO JLON=KDLUX+1,KDLON+KDAD ZJ = REAL(JLON - KDLUX,JPRB) PWORK(JLON,JFL,JLAT) = ZA + ZJ * (ZB + ZJ * (ZC + ZD * ZJ)) ENDDO ENDDO ZK = REAL(KDGL - KDGUX + 1,JPRB) ZKP1 = ZK + 1 ZLAM = ZK/ZKP1 ZNY = PALFA/ZKP1 DO JLON=KDLUN,IENDY+KDAD ZEPSA = ((PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK -& & PWORK(JLON,JFL,KDGUX)+PWORK(JLON,JFL,KDGUX-1))*6._JPRB/ZKP1-& & ZNY*(PWORK(JLON,JFL,KDGUX)-2.0_JPRB*PWORK(JLON,JFL,KDGUX-1)+& & PWORK(JLON,JFL,KDGUX-2)) ZEPSB = (PWORK(JLON,JFL,KDGUN+1)-PWORK(JLON,JFL,KDGUN) -& & (PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK)*6._JPRB/ZKP1-& & ZNY*(PWORK(JLON,JFL,KDGUN+2)-2.0_JPRB*PWORK(JLON,JFL,KDGUN+1) +& & PWORK(JLON,JFL,KDGUN)) ZMM = 4._JPRB - ZLAMB*ZLAMB ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ ZMM ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ ZMM ZA = PWORK(JLON,JFL,KDGUX) ZB = (PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK - (2.0_JPRB*& & ZM1 & & + ZM2) * ZK/6._JPRB ZC = 0.5_JPRB * ZM1 ZD = (ZM2 - ZM1)/(6._JPRB*ZK) DO JLAT=KDGUX+1,KDGL+KDAD ZJ = REAL(JLAT - KDGUX,JPRB) PWORK(JLON,JFL,JLAT) = ZA +ZJ*(ZB +ZJ*(ZC + ZJ * ZD)) ENDDO ENDDO ENDDO ! ------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESPLINE',1,ZHOOK_HANDLE) END SUBROUTINE ESPLINE END MODULE ESPLINE_MOD ectrans-1.8.0/src/etrans/gpu/biper/internal/esmoothe_mod.F900000664000175000017500000001227615174631767024131 0ustar alastairalastairMODULE ESMOOTHE_MOD CONTAINS SUBROUTINE ESMOOTHE(KDLUN,KDLON,KDGUN,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM,KDGSA,KDGEN,KNUBI,PWORK,LDBIX,LDBIY) ! purpose : ! -------- ! To smooth the fields over the extension zone. !* *CALL* *ESMOOTHE*(...) ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! KDLUN : lower bound for the x (or longitude) dimension ! of the gridpoint array ! KDLON : upper bound for the x (or longitude) dimension ! of the gridpoint array on C U I U E ! KDGUN : lower bound for the y (or latitude) dimension ! of the gridpoint array ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U E ! KDLUX : upper bound for the x (or longitude) dimension ! of C U I. ! KDGUX : upper bound for the y (or latitude) dimension ! of C U I. ! KDLSM : dimension in x direction of g-p array ! KDGSA : first dimension index in y of g-p array ! KDGEN : last dimension index in y of g-p array ! KSTART : first dimension index in x of g-p array ! KDLSM : last dimension index in x of g-p array ! KNUBI : number of levels to biperiodicise ! PWORK : gridpoint array on C U I U E. ! LDBIX : .TRUE.: biperiodicise in x direction (and vice versa) ! LDBIY : .TRUE.: biperiodicise in y direction (and vice versa) ! references : ! ---------- ! author : ! ------ ! Michal Batka and Radmila Bubnova ( B & B ) ! modifications : ! ------------- ! R. El Khatib 03-05-05 Optimizations ! -------------------------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK ! -------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KSTART INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA INTEGER(KIND=JPIM),INTENT(IN) :: KDGEN INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KDLUN INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGUN INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(KSTART:KDLSM,KNUBI,KDGSA:KDGEN) LOGICAL ,INTENT(IN) :: LDBIX LOGICAL ,INTENT(IN) :: LDBIY ! -------------------------------------------------------------- REAL(KIND=JPRB) :: ZPRAC(KDLUN-1:KDLON+1,KDGUN-1:KDGL+1) INTEGER(KIND=JPIM) :: IEND, IENX1, IENX2, IENY1, IENY2, JFL, JLAT, JLL, JLON REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! -------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESMOOTHE',0,ZHOOK_HANDLE) ! -------------------------------------------------------------- !* 1. Calculation. ! ------------ IEND = MAX(KDLON-KDLUX,KDGL-KDGUX) IEND = (IEND+1)/2 IENX1= KDLON IENX2= KDGL IENY1= KDGL IENY2= KDLON IF(LDBIX.AND.(.NOT.LDBIY)) THEN IENX2 = KDGUX IENY1 = KDGUX ELSEIF((.NOT.LDBIX).AND.LDBIY) THEN IENX1 = KDLUX IENY2 = KDLUX ELSEIF((.NOT.LDBIX).AND.(.NOT.LDBIY)) THEN IF (LHOOK) CALL DR_HOOK('ESMOOTHE',1,ZHOOK_HANDLE) RETURN ENDIF DO JFL = 1, KNUBI DO JLL = 1, IEND DO JLON = KDLUX,KDLON DO JLAT = KDGUN,KDGL ZPRAC(JLON,JLAT) = PWORK(JLON,JFL,JLAT) ENDDO ENDDO DO JLON = KDLUX,KDLON ZPRAC(JLON,KDGUN-1) = PWORK(JLON,JFL,KDGL) ZPRAC(JLON,KDGL +1) = PWORK(JLON,JFL,KDGUN) ENDDO DO JLAT = KDGUN,KDGL ZPRAC(KDLON+1,JLAT) = PWORK(KDLUN,JFL,JLAT) ENDDO ZPRAC(KDLON+1,KDGUN-1) = PWORK(KDLUN,JFL,KDGL) ZPRAC(KDLON+1,KDGL +1) = PWORK(KDLUN,JFL,KDGUN) DO JLON = KDLUX + JLL,IENX1 - JLL + 1 DO JLAT = KDGUN, IENX2 PWORK(JLON,JFL,JLAT)=(4._JPRB*ZPRAC(JLON,JLAT)+2.0_JPRB*(ZPRAC(JLON+& & 1,JLAT)+& & ZPRAC(JLON-1,JLAT) + ZPRAC(JLON,JLAT+1) +& & ZPRAC(JLON,JLAT-1)) + ZPRAC(JLON+1,JLAT+1) +& & ZPRAC(JLON-1,JLAT+1) + ZPRAC(JLON+1,JLAT-1)+& & ZPRAC(JLON-1,JLAT-1))/16._JPRB ENDDO ENDDO DO JLAT = KDGUX,KDGL DO JLON = KDLUN,KDLON ZPRAC(JLON,JLAT) = PWORK(JLON,JFL,JLAT) ENDDO ENDDO DO JLAT = KDGUX,KDGL ZPRAC(KDLUN-1,JLAT) = PWORK(KDLON,JFL,JLAT) ZPRAC(KDLON+1,JLAT) = PWORK(KDLUN,JFL,JLAT) ENDDO DO JLON = KDLUN,KDLON ZPRAC(JLON,KDGL +1) = PWORK(JLON,JFL,KDGUN) ENDDO ZPRAC(KDLUN-1,KDGL +1) = PWORK(KDLON,JFL,KDGUN) ZPRAC(KDLON+1,KDGL +1) = PWORK(KDLUN,JFL,KDGUN) DO JLAT = KDGUX + JLL, IENY1 - JLL + 1 DO JLON = KDLUN,IENY2 PWORK(JLON,JFL,JLAT)=(4._JPRB*ZPRAC(JLON,JLAT)+2.0_JPRB*(ZPRAC(JLON+& & 1,JLAT)+& & ZPRAC(JLON-1,JLAT) + ZPRAC(JLON,JLAT+1) +& & ZPRAC(JLON,JLAT-1)) + ZPRAC(JLON+1,JLAT+1) +& & ZPRAC(JLON-1,JLAT+1) + ZPRAC(JLON+1,JLAT-1)+& & ZPRAC(JLON-1,JLAT-1))/16._JPRB ENDDO ENDDO ENDDO ENDDO ! -------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESMOOTHE',1,ZHOOK_HANDLE) END SUBROUTINE ESMOOTHE END MODULE ESMOOTHE_MOD ectrans-1.8.0/src/etrans/gpu/biper/internal/ewindowe_mod.F900000664000175000017500000001045515174631767024124 0ustar alastairalastairMODULE EWINDOWE_MOD CONTAINS SUBROUTINE EWINDOWE(KDLON,KDLUX,KBWX,KDGL,KDGUX,KBWY,KFLD,PGPIN,PSCAL,LDBIX,LDBIY) ! purpose : ! -------- ! Make boyd periodic extension. ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! KDLON : upper bound for the x (or longitude) dimension ! of C U I U P. ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U P ! PGPIN : gridpoint array on C U I U P (gp:fields). ! PSCAL : window function scaling parameter ! LDBIX : .TRUE. windowing in x direction ( and vice versa ) ! LDBIY : .TRUE. windowing in y direction ( and vice versa ) ! references : ! ---------- ! author : Fabrice Voitus and Piet Termonia, 07/2009 ! ------ ! ! modification : ! Daan Degrauwe 02/2012 Cleaned and generalized ! S. Martinez 03/2012 Calls to ERF under CPP key __PGI ! (ERF function is not intrinsic with PGI) ! R. El Khatib 27-Sep-2013 implicit sized PGPIN ! R. El Khatib 04-Aug-2016 new interface ! ----------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KBWX INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KBWY INTEGER(KIND=JPIM),INTENT(IN) :: KFLD REAL(KIND=JPRB) ,INTENT(INOUT) :: PGPIN((KDLUX+2*KBWX+2*(KDLON-KDLUX))*(KDGUX+2*KBWY+2*(KDGL-KDGUX)),KFLD) REAL(KIND=JPRB) ,INTENT(IN) :: PSCAL LOGICAL ,INTENT(IN) :: LDBIX LOGICAL ,INTENT(IN) :: LDBIY ! FERF function ! ------------- #ifdef __PGI REAL(KIND=JPRB), EXTERNAL :: ERF #endif ! scalars ! -------- INTEGER(KIND=JPIM) :: JFL, JGL, JLON, IOFF, IDLW, IDGW INTEGER(KIND=JPIM) :: IWX, ILWX, IRWX, IWY, ILWY, IRWY, IBWXO, IBWYO INTEGER(KIND=JPIM) :: ILATF, ILONF, IND1, IND, IOFF_LEFT,IOFF_RIGHT,IOFF_BOTTOM,IOFF_TOP REAL(KIND=JPRB) :: ZI, ZJ, ZK, ZL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! local arrays : ! ------------ REAL(KIND=JPRB) :: ZBELX(2*KBWX+(KDLON-KDLUX)) REAL(KIND=JPRB) :: ZBELY(2*KBWY+(KDGL -KDGUX)) !* 1. Boyd Bi-periodic Extension Method. ! --------------------------------- IF (LHOOK) CALL DR_HOOK('EWINDOWE',0,ZHOOK_HANDLE) IF ((.NOT.LDBIX).AND.(.NOT.LDBIY)) THEN IF (LHOOK) CALL DR_HOOK('EWINDOWE',1,ZHOOK_HANDLE) RETURN ENDIF IDGW=SIZE(ZBELY) IDLW=SIZE(ZBELX) ! Bell window functions : ! --------------------- IF (LDBIX) THEN DO JLON=1,IDLW ! variable between -1 and 1 ZJ=REAL(-IDLW-1+2*JLON,JPRB)/(IDLW+1) ZL=ZJ/SQRT(1.0_JPRB-(ZJ*ZJ)) #ifdef __PGI ZBELX(JLON)=(1.0_JPRB+ERF(REAL(PSCAL*ZL)))/2.0_JPRB #else ZBELX(JLON)=(1.0_JPRB+ERF(PSCAL*ZL))/2.0_JPRB #endif ENDDO ENDIF IF (LDBIY) THEN DO JGL=1,IDGW ! variable between -1 and 1 ZJ=REAL(-IDGW-1+2*JGL,JPRB)/(IDGW+1) ZL=ZJ/SQRT(1.0_JPRB-(ZJ*ZJ)) #ifdef __PGI ZBELY(JGL)=(1.0_JPRB+ERF(REAL(PSCAL*ZL)))/2.0_JPRB #else ZBELY(JGL)=(1.0_JPRB+ERF(PSCAL*ZL))/2.0_JPRB #endif ENDDO ENDIF ! Windowing on P+G-zone : ! -------------------- IOFF=(KDLUX+2*(KBWX+KDGL-KDGUX)) IBWXO=KBWX+(KDLON-KDLUX) IBWYO=KBWY+(KDGL-KDGUX) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFL,JGL,JLON,ILONF,ILATF,IND1,IND,IOFF_LEFT,IOFF_RIGHT,IOFF_BOTTOM,IOFF_TOP) DO JFL=1,KFLD IF (LDBIX) THEN ! X-direction DO JGL=1,KDGL+IDGW IOFF_LEFT=(JGL-1)*IOFF IOFF_RIGHT=IOFF_LEFT+KDLON DO JLON=1,IDLW PGPIN(IOFF_RIGHT+JLON,JFL) = ZBELX(JLON)*PGPIN(IOFF_LEFT+JLON,JFL) +& & (1.0_JPRB-ZBELX(JLON))*PGPIN(IOFF_RIGHT+JLON,JFL) ENDDO ENDDO ENDIF IF (LDBIY) THEN ! Y-direction DO JGL=1,IDGW IOFF_BOTTOM=(JGL-1)*IOFF IOFF_TOP=(KDGL+JGL-1)*IOFF !DIR$ IVDEP DO JLON=1,KDLON+IDLW PGPIN(IOFF_TOP+JLON,JFL) = ZBELY(JGL)*PGPIN(IOFF_BOTTOM+JLON,JFL) +& & (1.0_JPRB-ZBELY(JGL))*PGPIN(IOFF_TOP+JLON,JFL) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO IF (LHOOK) CALL DR_HOOK('EWINDOWE',1,ZHOOK_HANDLE) END SUBROUTINE EWINDOWE END MODULE EWINDOWE_MOD ectrans-1.8.0/src/etrans/gpu/biper/external/0000775000175000017500000000000015174631767021165 5ustar alastairalastairectrans-1.8.0/src/etrans/gpu/biper/external/horiz_field.F900000664000175000017500000000360715174631767023751 0ustar alastairalastairSUBROUTINE HORIZ_FIELD(KX,KY,PHFIELD) ! purpose : ! -------- ! To produce test horizontal field of temperature. ! method : ! --------- ! Test horizontal input field is on horizontal grid size KXxKY points, and it ! represent's temperature. It is obtained form flollwing expression: ! PHFIELD(i,j)=280*(1+0.1*Sin[PPI*(i+0.5*IMAX)*(j+0.7*IMAX)/IMAX^2+1]) (Pierre Benard) ! interface : ! --------- ! CALL HORIZ_FIELD(KX,KY,PHFIELD) ! Explicit arguments : ! ------------------- ! KX - number of grid points in x ! KY - number of grid points in y ! PHFIELD - simulated 2D temperature horizontal field ! externals : ! ---------- ! None. ! references : ! ---------- ! author : ! ------ ! 23-May-2008 Antonio Stanesic ! ---------------------------------------------------------------------- USE PARKIND1 , ONLY : JPIM ,JPRB USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KX INTEGER(KIND=JPIM), INTENT(IN) :: KY REAL(KIND=JPRB), INTENT(OUT) :: PHFIELD(KX,KY) ! ---------------------------------------------------------------------- REAL(KIND=JPRB), PARAMETER :: PPI=3.141592 INTEGER(KIND=JPIM) :: JX,JY,IMAX REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('HORIZ_FIELD',0,ZHOOK_HANDLE) ! ---------------------------------------------------------------------- IMAX=MAX(KX,KY) DO JY=1,KY DO JX=1,KX PHFIELD(JX,JY)=280*(1+0.1*SIN(PPI*(JX+0.5*IMAX)*(JY+0.7*IMAX)/(IMAX**2)+1)) ENDDO ENDDO ! ---------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('HORIZ_FIELD',1,ZHOOK_HANDLE) END SUBROUTINE HORIZ_FIELD ectrans-1.8.0/src/etrans/gpu/biper/external/etibihie.F900000664000175000017500000000712615174631767023235 0ustar alastairalastairSUBROUTINE ETIBIHIE(KDLON,KDGL,KNUBI,KDLUX,KDGUX,& & KSTART,KDLSM,PGPBI,LDBIX,LDBIY,KDADD) !**** tool ETIBIHIE : Doubly-periodicisation : isotropic spline ! ------------- method. ! purpose : ! -------- ! KNUBI horizontal fields which are known on C U I, ! are extended over E, in order to obtain doubly-periodic ! fields. ! IF LDBIX is equal .TRUE. , then the fields are periodicise ! in the x ( or longitude ) direction. If it is not the case, ! KDLUX must be equal to KDLON. ! IF LDBIY is equal .TRUE. , then the fields are periodicise ! in the y ( or latitude ) direction. If it is not the case, ! KDGUX must be equal to KDGL. !* *CALL* *ETIBIHIE*(...) ! externals : ! ---------- ! ESPLIN spline extension ! ESMOOTH smoothing across to get isotropy. ! explicit arguments : ! ------------------ ! KDLON : upper bound for the x (or longitude) dimension ! of the gridpoint array on C U I U E ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U E ! KNUBI : number of horizontal fields to doubly-periodicise. ! KDLUX : upper bound for the x (or longitude) dimension ! of C U I. ! KDGUX : upper bound for the y (or latitude) dimension ! of C U I. ! KSTART : first dimension in x direction of g-p array ! KDLSM : second dimension in x direction of g-p array ! PGPBI : gridpoint array on C U I U E. ! LDBIX : logical to periodicize or not ! in the x ( or longitude ) direction. ! LDBIY : logical to periodicize or not ! in the y ( or latitude ) direction. ! KDADD : 1 to test biperiodiz. ! references : ! ---------- ! author : ! ------ ! V. Ducrocq ! modification : ! ------------ ! A. Stanesic 28/03/2008: KDADD - test of externalized biper. ! ------------------------------------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE ESPLINE_MOD USE ESMOOTHE_MOD ! ------------------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KSTART INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KDADD REAL(KIND=JPRB),INTENT(INOUT) :: PGPBI(KSTART:KDLSM+KDADD,KNUBI,1:KDGL+KDADD) LOGICAL,INTENT(IN) :: LDBIX LOGICAL,INTENT(IN) :: LDBIY ! ------------------------------------------------------------------------- REAL(KIND=JPRB) :: ZALFA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ETIBIHIE',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------------- !* 1. DOUBLY-PERIODICISE : ! ------------------ ZALFA = 0.0_JPRB CALL ESPLINE(1,KDLON,1,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM+KDADD,1,KDGL+KDADD,KNUBI,PGPBI,ZALFA,LDBIX,LDBIY,KDADD) CALL ESMOOTHE(1,KDLON,1,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM+KDADD,1,KDGL+KDADD,KNUBI,PGPBI,LDBIX,LDBIY) ! ------------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ETIBIHIE',1,ZHOOK_HANDLE) END SUBROUTINE ETIBIHIE ectrans-1.8.0/src/etrans/gpu/biper/external/fpbipere.F900000664000175000017500000001165515174631767023251 0ustar alastairalastairSUBROUTINE FPBIPERE(KDLUX,KDGUX,KDLON,KDGL,KNUBI,KD1,PGPBI,KDADD,LDZON, & & LDBOYD, KDBOYD, PLBOYD) !**** *FPBIPERE* - Full-POS interface for double periodicisation ! purpose : ! -------- ! To bi-periodicise the post-processed fields, or just fill the extension zone ! with the mean value of C+I area !** INTERFACE. ! ---------- ! *CALL* *FPBIPERE*(...) ! EXPLICIT ARGUMENTS ! -------------------- ! KDLUX : upper bound for the x (or longitude) dimension of C U I. ! KDGUX : upper bound for the y (or latitude) dimension of C U I. ! KDLON : upper bound for the x (or longitude) dimension of the gridpoint array on C U I U E ! KDGL : upper bound for the y (or latitude) dimension of the gridpoint array on C U I U E ! KNUBI : number of horizontal fields to doubly-periodicise. ! KD1 : dimension of input/output array ! PGPBI : input/output gridpoint array on C U I U E. ! LDZON : .true. if input grid on C U I U E (.false. if C U I) ! KDADD : 1 to test biperiodiz. ! LDBOYD: perform boyd periodization (inside C U I) ! KDBOYD: array containing dimensions of boyd domain ! PLBOYD: scalar parameter for boyd (variable L in paper) ! IMPLICIT ARGUMENTS ! -------------------- ! METHOD. ! ------- ! SEE DOCUMENTATION ! EXTERNALS. ! ---------- ! ESPLINE spline extension ! ESMOOTHE smoothing across to get isotropy. ! REFERENCE. ! ---------- ! ECMWF Research Department documentation of the IFS ! AUTHOR. ! ------- ! RYAD EL KHATIB *METEO-FRANCE* ! MODIFICATIONS. ! -------------- ! R. El Khatib : 01-08-07 Pruning options ! M.Hamrud : 01-Oct-2003 CY28 Cleaning ! F. Taillefer : 04-10-21 Add LDZON ! A. Stanesic : 28-03-08: KDADD - test of externalized biper. ! D. Degrauwe : feb 2012 Boyd periodization ! R. El Khatib 27-Sep-2013 Boyd periodization in Fullpos-2 ! R. El Khatib 04-Aug-2016 new interface to ewindowe + cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE ESPLINE_MOD USE ESMOOTHE_MOD USE EWINDOWE_MOD ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KD1 INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDADD REAL(KIND=JPRB) ,INTENT(INOUT) :: PGPBI(KD1,KNUBI) LOGICAL, OPTIONAL ,INTENT(IN) :: LDZON LOGICAL ,INTENT(IN) ,OPTIONAL :: LDBOYD INTEGER(KIND=JPIM),INTENT(IN) ,OPTIONAL :: KDBOYD(6) REAL(KIND=JPRB) ,INTENT(IN) ,OPTIONAL :: PLBOYD ! ------------------------------------------------------------------ REAL(KIND=JPRB), ALLOCATABLE :: ZGPBI(:,:,:) INTEGER(KIND=JPIM) :: IND, ISTAE, JGL, JLON, JNUBI, IBWX, IBWY LOGICAL :: LLZON, LLBOYD REAL(KIND=JPRB) :: ZALFA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE #include "abor1.intfb.h" ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('FPBIPERE',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ LLBOYD=.FALSE. IF (PRESENT(LDBOYD)) LLBOYD=LDBOYD !* 2. DOUBLY-PERIODICISE ! ------------------ IF (LLBOYD) THEN IF (.NOT.PRESENT(KDBOYD)) CALL ABOR1('FPBIPERE: Boyd periodization requires KDBOYD argument') IF (.NOT.PRESENT(PLBOYD)) CALL ABOR1('FPBIPERE: Boyd periodization requires PLBOYD argument') IBWX=KDBOYD(3) IBWY=KDBOYD(6) CALL EWINDOWE(KDLON,KDLUX,IBWX,KDGL,KDGUX,IBWY,KNUBI,PGPBI,PLBOYD,.TRUE.,.TRUE.) ELSE LLZON=.FALSE. IF(PRESENT(LDZON)) LLZON=LDZON ALLOCATE(ZGPBI(KDLON+KDADD,KNUBI,KDGL+KDADD)) IF(LLZON) THEN ! Copy C+I+E IND=KDLON ELSE ! Copy C+I IND=KDLUX ENDIF !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JNUBI,ISTAE,JGL,JLON) DO JNUBI=1,KNUBI ISTAE=0 DO JGL=1,KDGUX DO JLON=1,KDLUX ZGPBI(JLON,JNUBI,JGL)=PGPBI(ISTAE+JLON,JNUBI) ENDDO ISTAE=ISTAE+IND ENDDO ENDDO !$OMP END PARALLEL DO ZALFA = 0.0_JPRB CALL ESPLINE(1,KDLON,1,KDGL,KDLUX,KDGUX,1,KDLON+KDADD,1,KDGL+KDADD,KNUBI,ZGPBI,& & ZALFA,.TRUE.,.TRUE.,KDADD) CALL ESMOOTHE(1,KDLON,1,KDGL,KDLUX,KDGUX,1,KDLON+KDADD,1,KDGL+KDADD,KNUBI,ZGPBI,& & .TRUE.,.TRUE.) !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JNUBI,ISTAE,JGL,JLON) DO JNUBI=1,KNUBI ISTAE=0 DO JGL=1,KDGL DO JLON=1,KDLON PGPBI(ISTAE+JLON,JNUBI)=ZGPBI(JLON,JNUBI,JGL) ENDDO ISTAE=ISTAE+KDLON ENDDO ENDDO !$OMP END PARALLEL DO DEALLOCATE(ZGPBI) ENDIF ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('FPBIPERE',1,ZHOOK_HANDLE) END SUBROUTINE FPBIPERE ectrans-1.8.0/src/etrans/cpu/0000775000175000017500000000000015174631767016236 5ustar alastairalastairectrans-1.8.0/src/etrans/cpu/internal/0000775000175000017500000000000015174631767020052 5ustar alastairalastairectrans-1.8.0/src/etrans/cpu/internal/eprfi2b_mod.F900000664000175000017500000000607415174631767022531 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI2B_MOD CONTAINS SUBROUTINE EPRFI2B(KFIELD,KM,KMLOC,PFFT) !**** *EPRFI2B* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *EPRFI2B(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM ! Implicit arguments : FOUBUF in TPM_TRANS ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 90-07-01 ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF !USE TPM_GEOMETRY USE TPM_DISTR ,ONLY : D !USE TPMALD_DIM ,ONLY : RALD ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD,KM,KMLOC REAL(KIND=JPRB) , INTENT(OUT) :: PFFT(:,:) INTEGER(KIND=JPIM) :: ISTAN, JF, JGL INTEGER(KIND=JPIM) :: IJR,IJI REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EPRFI2B_MOD:EPRFI2B',0,ZHOOK_HANDLE) !* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. ! ------------------------------------------------ !DIR$ IVDEP !OCL NOVREC DO JGL=1,R%NDGL ISTAN = (D%NSTAGT1B(D%NPROCL(JGL) )+D%NPNTGTB1(KMLOC,JGL ))*2*KFIELD DO JF =1,KFIELD IJR = 2*(JF-1)+1 IJI = IJR+1 PFFT(JGL,IJR) = FOUBUF(ISTAN+IJR) PFFT(JGL,IJI) = FOUBUF(ISTAN+IJI) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EPRFI2B_MOD:EPRFI2B',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI2B END MODULE EPRFI2B_MOD ectrans-1.8.0/src/etrans/cpu/internal/eprfi1bad_mod.F900000664000175000017500000000670415174631767023035 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI1BAD_MOD CONTAINS SUBROUTINE EPRFI1BAD(KM,PIA,PSPEC,KFIELDS,KFLDPTR) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPMALD_DISTR ,ONLY : DALD !**** *EPRFI1BAD* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *EPRFI1BAD(...)* ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPEC - spectral array ! KFIELDS - number of fields ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1BAD in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELDS REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PIA(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF, IFLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- IF (LHOOK) CALL DR_HOOK('EPRFI1BAD_MOD:EPRFI1BAD',0,ZHOOK_HANDLE) ILCM=DALD%NCPL2M(KM) IOFF = DALD%NESM0(KM) IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 IFLD = KFLDPTR(JFLD) DO J=1,ILCM,2 INM = IOFF+(J-1)*2 PSPEC(IFLD,INM ) = PSPEC(IFLD,INM ) + PIA(J ,IR) PSPEC(IFLD,INM+1) = PSPEC(IFLD,INM+1) + PIA(J+1,IR) PSPEC(IFLD,INM+2) = PSPEC(IFLD,INM+2) + PIA(J ,II) PSPEC(IFLD,INM+3) = PSPEC(IFLD,INM+3) + PIA(J+1,II) ENDDO ENDDO ELSE DO J=1,ILCM,2 INM = IOFF+(J-1)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 PSPEC(JFLD,INM ) = PSPEC(JFLD,INM ) + PIA(J ,IR) PSPEC(JFLD,INM+1) = PSPEC(JFLD,INM+1) + PIA(J+1,IR) PSPEC(JFLD,INM+2) = PSPEC(JFLD,INM+2) + PIA(J ,II) PSPEC(JFLD,INM+3) = PSPEC(JFLD,INM+3) + PIA(J+1,II) ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('EPRFI1BAD_MOD:EPRFI1BAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI1BAD END MODULE EPRFI1BAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eledir_mod.F900000664000175000017500000000631415174631767022441 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELEDIR_MOD CONTAINS SUBROUTINE ELEDIR(KM,KFC,KLED2,PFFT) !**** *ELEDIR* - Direct meridional transform. ! Purpose. ! -------- ! Direct meridional tranform of state variables. !** Interface. ! ---------- ! CALL ELEDIR(...) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFC - number of field to transform ! PAIA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSIA - symmetric part of Fourier ! fields for zonal wavenumber KM ! POA1 - spectral ! fields for zonal wavenumber KM ! PLEPO - Legendre polonomials ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - matrix multiply ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-01-28 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 93-03-19 D. Giard - NTMAX instead of NSMAX ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 01-Sep-2015 support for FFTW transforms ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK USE TPM_DIM ,ONLY : R !USE TPM_GEOMETRY !USE TPM_TRANS #ifdef WITH_FFT992 USE TPMALD_FFT ,ONLY : TALD #endif USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW USE TPMALD_DIM ,ONLY : RALD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM,KFC,KLED2 REAL(KIND=JPRB) , INTENT(INOUT) :: PFFT(:,:) INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE ! ------------------------------------------------------------------ !* 1. PERFORM FOURIER TRANFORM. ! -------------------------- IF (KFC>0) THEN ITYPE=-1 IRLEN=R%NDGL+R%NNOEXTZG ICLEN=RALD%NDGLSUR+R%NNOEXTZG #ifdef WITH_FFT992 IF( TALD%LFFT992 )THEN CALL FFT992(PFFT,TALD%TRIGSE,TALD%NFAXE,1,ICLEN,IRLEN,KFC,ITYPE) #endif IOFF=1 CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PFFT) #ifdef WITH_FFT992 ENDIF #endif ENDIF ! ------------------------------------------------------------------ END SUBROUTINE ELEDIR END MODULE ELEDIR_MOD ectrans-1.8.0/src/etrans/cpu/internal/edir_trans_ctl_mod.F900000664000175000017500000001745215174631767024176 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EDIR_TRANS_CTL_MOD CONTAINS SUBROUTINE EDIR_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV,AUX_PROC) !**** *EDIR_TRANS_CTL* - Control routine for direct spectral transform. ! Purpose. ! -------- ! Control routine for the direct spectral transform !** Interface. ! ---------- ! CALL EDIR_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity ! PSPDIV(:,:) - spectral divergence ! PSPSCALAR(:,:) - spectral scalarvalued fields ! 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. ! PMEANU,PMEANV - mean winds ! AUX_PROC - optional external procedure for biperiodization of ! aux.fields ! PGP(:,:,:) - gridpoint fields ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! G. Radnoti 01-03-13 adaptation to aladin ! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 ! 02-09-30 : P. Smolikova AUX_PROC for d4 in NH ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NPROMATR !USE TPM_TRANS !USE TPM_DISTR USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE ELTDIR_CTL_MOD ,ONLY : ELTDIR_CTL USE EFTDIR_CTL_MOD ,ONLY : EFTDIR_CTL IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS 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(:,:) 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(:) 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(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANV(:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Perform transform IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTL_MOD:EDIR_TRANS_CTL',0,ZHOOK_HANDLE) IF_GPB = 2*KF_UV_G+KF_SCALARS_G IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & & KVSETUV,KVSETSC) IBLKS=(IF_GPB-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G DO JFLD=1,IF_UV_G IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDDO DO JFLD=1,IF_SCALARS_G IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL EFTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL EFTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KPTRGP=IPTRGP,PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL EFTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP,& & AUX_PROC=AUX_PROC) ENDIF CALL ELTDIR_CTL(IF_FS,IF_UV,IF_SCALARS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& & PSPMEANU=PMEANU,PSPMEANV=PMEANV,AUX_PROC=AUX_PROC) ENDDO ELSE ! No splitting of fields, transform done in one go CALL EFTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,IF_GPB,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2,& & AUX_PROC=AUX_PROC) CALL ELTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& & PSPMEANU=PMEANU,PSPMEANV=PMEANV,& & AUX_PROC=AUX_PROC) ENDIF IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTL_MOD:EDIR_TRANS_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EDIR_TRANS_CTL END MODULE EDIR_TRANS_CTL_MOD ectrans-1.8.0/src/etrans/cpu/internal/eprfi1b_mod.F900000664000175000017500000000647615174631767022536 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI1B_MOD CONTAINS SUBROUTINE EPRFI1B(KM,PIA,PSPEC,KFIELDS,KFLDPTR) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DIM !USE TPM_DISTR USE TPMALD_DISTR ,ONLY : DALD ! !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1B(...)* ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPEC - spectral array ! KFIELDS - number of fields ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1B in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELDS REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PIA(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF,IFLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- IF (LHOOK) CALL DR_HOOK('EPRFI1B_MOD:EPRFI1B',0,ZHOOK_HANDLE) ILCM = DALD%NCPL2M(KM) IOFF = DALD%NESM0(KM) IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 IFLD = KFLDPTR(JFLD) DO J=1,ILCM,2 INM = IOFF+(J-1)*2 PIA(J ,IR) = PSPEC(IFLD,INM ) PIA(J+1,IR) = PSPEC(IFLD,INM+1) PIA(J ,II) = PSPEC(IFLD,INM+2) PIA(J+1,II) = PSPEC(IFLD,INM+3) ENDDO ENDDO ELSE DO J=1,ILCM,2 INM = IOFF+(J-1)*2 !DIR$ IVDEP !OCL NOVREC !cdir unroll=4 DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 PIA(J ,IR) = PSPEC(JFLD,INM ) PIA(J+1,IR) = PSPEC(JFLD,INM+1) PIA(J ,II) = PSPEC(JFLD,INM+2) PIA(J+1,II) = PSPEC(JFLD,INM+3) ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('EPRFI1B_MOD:EPRFI1B',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI1B END MODULE EPRFI1B_MOD ectrans-1.8.0/src/etrans/cpu/internal/eltdir_mod.F900000664000175000017500000001407015174631767022456 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTDIR_MOD CONTAINS SUBROUTINE ELTDIR(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPMALD_DIM ,ONLY : RALD USE EPRFI2_MOD ,ONLY : EPRFI2 USE ELEDIR_MOD ,ONLY : ELEDIR USE EUVTVD_MOD USE EUPDSP_MOD ,ONLY : EUPDSP USE EXTPER_MOD ,ONLY : EXTPER ! !**** *ELTDIR* - Control of Direct Legendre transform step ! Purpose. ! -------- ! Tranform from Fourier space to spectral space, compute ! vorticity and divergence. !** Interface. ! ---------- ! *CALL* *ELTDIR(...)* ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! EPRFI2 - prepares the Fourier work arrays for model variables ! ELEDIR - direct Legendre transform ! EUVTVD - ! EUPDSP - updating of spectral arrays (fields) ! EUVTVD_COMM - ! EXTPER - ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-24 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified 94-04-06 R. El khatib Full-POS implementation ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group : 95-10-01 Support for Distributed Memory version ! K. YESSAD (AUGUST 1996): ! - Legendre transforms for transmission coefficients. ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! 01-03-14 G. Radnoti aladin version ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM INTEGER(KIND=JPIM),INTENT(IN) :: KMLOC INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 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) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANV(:) INTEGER(KIND=JPIM) :: IFC, IINDEX(2*KF_FS), JF, JDIM INTEGER(KIND=JPIM) :: IFLD, IR, J INTEGER(KIND=JPIM) :: IUS,IVS,IVORS,IDIVS REAL(KIND=JPRB) :: ZFFT(RALD%NDGLSUR+R%NNOEXTZG,KLED2,D%NUMP) REAL(KIND=JPRB) :: ZVODI(RALD%NDGLSUR+R%NNOEXTZG,MAX(4*KF_UV,1),D%NUMP) ! Only if R%NNOEXTZG > 0 : REAL(KIND=JPRB) :: ZFFT2(KLED2,(RALD%NDGLSUR+R%NNOEXTZG)*MIN(1,R%NNOEXTZG)) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ELTDIR_MOD:ELTDIR',0,ZHOOK_HANDLE) IUS = 1 IVS = 2*KF_UV+1 IVORS = IUS IDIVS = IVS IFC = 2*KF_FS !* 1. PREPARE WORK ARRAYS. ! -------------------- CALL EPRFI2(KM,KMLOC,KF_FS,ZFFT(:,:,KMLOC)) !* 2. PERIODICIZATION IN Y DIRECTION ! ------------------------------ IF(R%NNOEXTZG>0) THEN DO JF = 1,IFC DO JDIM = 1,R%NDGL ZFFT2(JF,JDIM)=ZFFT(JDIM,JF,KMLOC) ENDDO ENDDO IINDEX(1)=0 CALL EXTPER(ZFFT2(:,:),R%NDGL+R%NNOEXTZG,1,R%NDGL,IFC,1,IINDEX,0) DO JF = 1,IFC DO JDIM = 1,R%NDGL+R%NNOEXTZG ZFFT(JDIM,JF,KMLOC) = ZFFT2(JF,JDIM) ENDDO ENDDO ENDIF !* 3. DIRECT LEGENDRE TRANSFORM. ! -------------------------- CALL ELEDIR(KM,IFC,KLED2,ZFFT(:,:,KMLOC)) !* 4. COMPUTE VORTICITY AND DIVERGENCE AND STORE MEAN WIND ON TASK OWNING WAVE 0 ! -------------------------------------------------------------------------- IF( KF_UV > 0 ) THEN CALL EUVTVD(KM,KMLOC,KF_UV,ZFFT(:,IUS:,KMLOC),ZFFT(:,IVS:,KMLOC),& & ZVODI(:,IVORS:,KMLOC),ZVODI(:,IDIVS:,KMLOC)) IF (KM == 0) THEN IF (PRESENT(KFLDPTRUV)) THEN DO J = 1, KF_UV IR = 2*J-1 IFLD=KFLDPTRUV(J) PSPMEANU(IFLD)=ZFFT(1,IUS-1+IR,KMLOC) PSPMEANV(IFLD)=ZFFT(1,IVS-1+IR,KMLOC) ENDDO ELSE DO J = 1, KF_UV IR = 2*J-1 PSPMEANU(J)=ZFFT(1,IUS-1+IR,KMLOC) PSPMEANV(J)=ZFFT(1,IVS-1+IR,KMLOC) ENDDO ENDIF ENDIF ENDIF !* 5. UPDATE SPECTRAL ARRAYS. ! ----------------------- CALL EUPDSP(KM,KF_UV,KF_SCALARS,ZFFT(:,:,KMLOC),ZVODI(:,:,KMLOC), & & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,KFLDPTRUV,KFLDPTRSC) IF (LHOOK) CALL DR_HOOK('ELTDIR_MOD:ELTDIR',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTDIR END MODULE ELTDIR_MOD ectrans-1.8.0/src/etrans/cpu/internal/eupdsp_mod.F900000664000175000017500000001073315174631767022475 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EUPDSP_MOD CONTAINS SUBROUTINE EUPDSP(KM,KF_UV,KF_SCALARS,PFFT,PVODI, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) !**** *EUPDSP* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update the spectral arrays for a fixed zonal wave-number ! from values in POA1 and POA2. !** Interface. ! ---------- ! CALL EUPDSP(...) ! Explicit arguments : ! -------------------- ! KM - zonal wave-number ! POA1 - spectral fields for zonal wavenumber KM (basic var.) ! POA2 - spectral fields for zonal wavenumber KM (vor. div.) ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Externals. UPDSPB - basic transfer routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 94-08-02 R. El Khatib - interface to UPDSPB ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B !USE TPM_DISTR USE EUPDSPB_MOD ,ONLY : EUPDSPB ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV,KF_SCALARS REAL(KIND=JPRB) , INTENT(IN) :: PFFT(:,:) REAL(KIND=JPRB) , INTENT(IN) :: PVODI(:,:) 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) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND,IDIM1,IDIM3,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. UPDATE FIELDS ! ------------- !* 1.1 VORTICITY AND DIVERGENCE. IF (LHOOK) CALL DR_HOOK('EUPDSP_MOD:EUPDSP',0,ZHOOK_HANDLE) IST = 1 IF (KF_UV > 0) THEN IST = IST+4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV CALL EUPDSPB(KM,KF_UV,PVODI(:,IVORS:IVORE),PSPVOR,KFLDPTRUV) CALL EUPDSPB(KM,KF_UV,PVODI(:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) ENDIF !* 1.2 SCALARS IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IEND = IST+2*KF_SCALARS-1 CALL EUPDSPB(KM,KF_SCALARS,PFFT(:,IST:IEND),PSPSCALAR,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IDIM1 = NF_SC2 IEND = IST+2*IDIM1-1 CALL EUPDSPB(KM,IDIM1,PFFT(:,IST:IEND),PSPSC2) IST=IST+2*IDIM1 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL EUPDSPB(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3A(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL EUPDSPB(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3B(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('EUPDSP_MOD:EUPDSP',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EUPDSP END MODULE EUPDSP_MOD ectrans-1.8.0/src/etrans/cpu/internal/eltinvad_mod.F900000664000175000017500000001634715174631767023012 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTINVAD_MOD CONTAINS SUBROUTINE ELTINVAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) !**** *ELTINVAD* - Control routine for inverse Legandre transform - adj. ! Purpose. ! -------- ! Control routine for the inverse LEGENDRE transform !** Interface. ! ---------- ! CALL ELTINVAD(...) ! KF_OUT_LT - number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! KFLDPTRUV(:) - field pointer array for vor./div. ! KFLDPTRSC(:) - field pointer array for PSPSCALAR ! Method. ! ------- ! Externals. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINVAD in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! 01-Dec-2004 A. Deckmyn add KMLOC to EVDTUVAD call ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + ! thread-safety ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B USE TPM_DISTR USE EASRE1BAD_MOD ,ONLY : EASRE1BAD USE ELEINVAD_MOD ,ONLY : ELEINVAD USE EPRFI1BAD_MOD ,ONLY : EPRFI1BAD USE ESPNSDEAD_MOD ,ONLY : ESPNSDEAD USE EVDTUVAD_MOD ,ONLY : EVDTUVAD USE EVDTUVAD_COMM_MOD USE EXTPER_MOD ,ONLY : EXTPER IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) :: ZIA(RALD%NDGLSUR+R%NNOEXTZG,KLEI2,D%NUMP) REAL(KIND=JPRB) :: ZIA2(KLEI2,RALD%NDGLSUR+R%NNOEXTZG) INTEGER(KIND=JPIM) :: IFC, ISTA, IINDEX(2*KF_OUT_LT), JF, JDIM, IM, JM INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU INTEGER(KIND=JPIM) :: ILAST,IFIRST,IDIM1,IDIM3,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ELTINVAD_MOD:ELTINVAD',0,ZHOOK_HANDLE) IF (KF_UV > 0) THEN IVORL = 1 IVORU = 2*KF_UV IDIVL = 2*KF_UV+1 IDIVU = 4*KF_UV IUL = 4*KF_UV+1 IUU = 6*KF_UV IVL = 6*KF_UV+1 IVU = 8*KF_UV ENDIF ISTA = 1 IFC = 2*KF_OUT_LT IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN ISTA = ISTA+2*KF_UV ENDIF IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN ISTA = ISTA+2*KF_UV ENDIF IF (KF_SCDERS > 0) THEN ISL = 2*(4*KF_UV)+1 ISU = ISL+2*KF_SCALARS-1 IDL = 2*(4*KF_UV+KF_SCALARS)+1 IDU = IDL+2*KF_SCDERS-1 ENDIF !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM,JF,JDIM,IINDEX,ZIA2) DO JM=1,D%NUMP IM = D%MYMS(JM) !* 6. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. ! -------------------------------------------- ZIA(:,:,JM)=0.0_JPRB CALL EASRE1BAD(IFC,IM,JM,ZIA(:,ISTA:ISTA+IFC-1,JM)) !* 5. PERIODICIZATION IN Y DIRECTION ! ------------------------------ IF(R%NNOEXTZG>0) THEN DO JF = 1,IFC DO JDIM = 1,R%NDGL ZIA2(JF,JDIM)=ZIA(JDIM,JF,JM) ENDDO ENDDO IINDEX(1)=0 CALL EXTPER(ZIA2(:,:),R%NDGL+R%NNOEXTZG,1,R%NDGL,IFC,1,IINDEX,0) DO JF = 1,IFC DO JDIM = 1,R%NDGL+R%NNOEXTZG ZIA(JDIM,JF,JM) = ZIA2(JF,JDIM) ENDDO ENDDO ENDIF !* 4. INVERSE LEGENDRE TRANSFORM. ! --------------------------- CALL ELEINVAD(IM,IFC,KF_OUT_LT,ZIA(:,ISTA:ISTA+IFC-1,JM)) !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- ZIA(:,1:ISTA-1,JM) = 0.0_JPRB IF (KF_UV > 0) THEN CALL EVDTUVAD(IM,JM,KF_UV,KFLDPTRUV,ZIA(:,IVORL:IVORU,JM),ZIA(:,IDIVL:IDIVU,JM),& & ZIA(:,IUL:IUU,JM),ZIA(:,IVL:IVU,JM),PSPMEANU,PSPMEANV) ENDIF ENDDO !$OMP END PARALLEL DO !* 2. COMMUNICATION OF MEAN WIND ! -------------------------- IF (KF_UV > 0) THEN DO JM=1,D%NUMP IM = D%MYMS(JM) CALL EVDTUVAD_COMM(IM,JM,KF_UV,KFLDPTRUV,PSPMEANU,PSPMEANV) ENDDO ENDIF !* 2. PREPARE SPECTRAL FIELDS ! ----------------------- !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM,IFIRST,ILAST,IDIM1,IDIM3) DO JM=1,D%NUMP IM = D%MYMS(JM) IFIRST = 1 ILAST = 4*KF_UV IF (KF_UV > 0) THEN CALL EPRFI1BAD(IM,ZIA(:,IVORL:IVORU,JM),PSPVOR,KF_UV,KFLDPTRUV) CALL EPRFI1BAD(IM,ZIA(:,IDIVL:IDIVU,JM),PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV ENDIF IF (KF_SCDERS > 0) THEN CALL ESPNSDEAD(IM,KF_SCALARS,ZIA(:,ISL:ISU,JM),ZIA(:,IDL:IDU,JM)) ENDIF IF(KF_SCALARS > 0)THEN IF(PRESENT(PSPSCALAR)) THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IFIRST = ILAST+1 ILAST = IFIRST-1+2*NF_SC2 CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSC2(:,:),NF_SC2) ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSC3A(:,:,J3),IDIM1) ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL EPRFI1BAD(IM,ZIA(:,IFIRST:ILAST,JM),PSPSC3B(:,:,J3),IDIM1) ENDDO ENDIF ENDIF ENDIF ENDDO !$OMP END PARALLEL DO IF (LHOOK) CALL DR_HOOK('ELTINVAD_MOD:ELTINVAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTINVAD END MODULE ELTINVAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eupdspb_mod.F900000664000175000017500000000622515174631767022640 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EUPDSPB_MOD CONTAINS SUBROUTINE EUPDSPB(KM,KFIELD,POA,PSPEC,KFLDPTR) !**** *EUPDSPB* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update spectral arrays for a fixed zonal wave-number ! from values in POA. !** Interface. ! ---------- ! CALL EUPDSPB(....) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFIELD - number of fields ! POA - work array ! PSPEC - spectral array ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the ! first and last field ! L. Isaksen : 95-06-06 Reordering of spectral arrays ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DIM !USE TPM_FIELDS !USE TPM_DISTR USE TPMALD_DISTR ,ONLY : DALD ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELD REAL(KIND=JPRB) ,INTENT(IN) :: POA(:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN,IFLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. UPDATE SPECTRAL FIELDS. ! ----------------------- IF (LHOOK) CALL DR_HOOK('EUPDSPB_MOD:EUPDSPB',0,ZHOOK_HANDLE) IF(PRESENT(KFLDPTR)) THEN DO JN=1,DALD%NCPL2M(KM),2 INM=DALD%NESM0(KM)+(JN-1)*2 DO JFLD=1,KFIELD IR= 2*JFLD-1 II=IR+1 IFLD = KFLDPTR(JFLD) PSPEC(IFLD,INM) =POA(JN,IR) PSPEC(IFLD,INM+1) =POA(JN+1,IR) PSPEC(IFLD,INM+2) =POA(JN,II) PSPEC(IFLD,INM+3) =POA(JN+1,II) ENDDO ENDDO ELSE DO JN=1,DALD%NCPL2M(KM),2 INM=DALD%NESM0(KM)+(JN-1)*2 ! use unroll to provoke vectorization of outer loop !cdir unroll=4 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELD IR= 2*JFLD-1 II=IR+1 PSPEC(JFLD,INM) =POA(JN,IR) PSPEC(JFLD,INM+1) =POA(JN+1,IR) PSPEC(JFLD,INM+2) =POA(JN,II) PSPEC(JFLD,INM+3) =POA(JN+1,II) ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('EUPDSPB_MOD:EUPDSPB',1,ZHOOK_HANDLE) END SUBROUTINE EUPDSPB END MODULE EUPDSPB_MOD ectrans-1.8.0/src/etrans/cpu/internal/suemp_trans_mod.F900000664000175000017500000002147515174631767023542 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE SUEMP_TRANS_MOD CONTAINS SUBROUTINE SUEMP_TRANS ! Set up distributed environment for the transform package (part 2) ! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, NPRTRNS, NPRTRV, NPRTRW, MYSETW, NPROC, MYPROC USE TPMALD_DIM ,ONLY : RALD !USE TPMALD_DISTR !USE SUWAVEDI_MOD !USE PE2SET_MOD USE SUMPLATF_MOD ,ONLY : SUMPLATF USE SUEMPLAT_MOD ,ONLY : SUEMPLAT USE SUESTAONL_MOD ,ONLY : SUESTAONL USE MYSENDSET_MOD ,ONLY : MYSENDSET USE MYRECVSET_MOD ,ONLY : MYRECVSET USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & & N_REGIONS, N_REGIONS_EW, N_REGIONS_NS ! IMPLICIT NONE INTEGER(KIND=JPIM) :: JM,JMLOC INTEGER(KIND=JPIM) :: JGL,IGL,IPLAT,ISENDSET,IRECVSET,JML,IPOS,IM INTEGER(KIND=JPIM) :: I1,I2,I3,IAUX0,IAUX1,JA1 INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF INTEGER(KIND=JPIM), ALLOCATABLE :: IGPTOTL(:,:) REAL(KIND=JPRD) :: ZMEDIAP LOGICAL :: LLP1,LLP2 REAL(KIND=JPRD),ALLOCATABLE :: ZDUM(:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_MOD:SUEMP_TRANS',0,ZHOOK_HANDLE) LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEMP_TRANS ===' IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NULTPP(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NULTPP ',SIZE(D%NULTPP ),SHAPE(D%NULTPP ) ALLOCATE(D%NPTRLS(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLS ',SIZE(D%NPTRLS ),SHAPE(D%NPTRLS ) ALLOCATE(D%NPROCL(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCL ',SIZE(D%NPROCL ),SHAPE(D%NPROCL ) CALL SUMPLATF(R%NDGL,NPRTRNS,MYSETW,D%NULTPP,D%NPROCL,D%NPTRLS) D%NDGL_FS = D%NULTPP(MYSETW) ! Help arrays for spectral to fourier space transposition ALLOCATE(D%NLTSGTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSGTB ',SIZE(D%NLTSGTB),SHAPE(D%NLTSGTB) ALLOCATE(D%NLTSFTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSFTB ',SIZE(D%NLTSFTB),SHAPE(D%NLTSFTB) ALLOCATE(D%NSTAGT0B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT0B ',SIZE(D%NSTAGT0B),SHAPE(D%NSTAGT0B) ALLOCATE(D%NSTAGT1B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT1B ',SIZE(D%NSTAGT1B),SHAPE(D%NSTAGT1B) ALLOCATE(D%MSTABF (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%MSTABF ',SIZE(D%MSTABF),SHAPE(D%MSTABF) D%NLTSGTB(:) = 0 DO JGL=1,D%NDGL_FS IGL = D%NPTRLS(MYSETW)+JGL-1 DO JM=0,G%NMEN(IGL) D%NLTSGTB(D%NPROCM(JM)) = D%NLTSGTB(D%NPROCM(JM))+1 ENDDO ENDDO DO JA=1,NPRTRW IPLAT = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA)+JGL-1 DO JM=1,D%NUMP IF(IGL > R%NDGNH-G%NDGLU(D%MYMS(JM)) .AND. IGL <= R%NDGNH+G%NDGLU(D%MYMS(JM))) THEN IPLAT = IPLAT + 1 ENDIF ENDDO ENDDO D%NLTSFTB(JA) = IPLAT ENDDO DO JA=1,NPRTRW-1 ISENDSET = MYSENDSET(NPRTRW,MYSETW,JA) IRECVSET = MYRECVSET(NPRTRW,MYSETW,JA) D%MSTABF(IRECVSET) = ISENDSET ENDDO D%MSTABF(MYSETW) = MYSETW ALLOCATE(D%NPNTGTB0(0:RALD%NMSMAX,D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB0 ',SIZE(D%NPNTGTB0 ),SHAPE(D%NPNTGTB0 ) ALLOCATE(D%NPNTGTB1(D%NUMP,R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB1 ',SIZE(D%NPNTGTB1 ),SHAPE(D%NPNTGTB1 ) DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(MYSETW) IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JML=D%NPTRMS(JA),D%NPTRMS(JA)+D%NUMPP(JA)-1 IM = D%NALLMS(JML) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB0(IM,JGL) = IPOS IPOS = IPOS+1 ELSE D%NPNTGTB0(IM,JGL) = -99 ENDIF ENDDO ENDDO ENDDO DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA) + JGL - 1 DO JM=1,D%NUMP IM = D%MYMS(JM) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB1(JM,IGL) = IPOS IPOS = IPOS+1 ELSE D%NPNTGTB1(JM,IGL) = -99 ENDIF ENDDO ENDDO ENDDO IAUX0 = 0 IAUX1 = 0 DO JA=1,NPRTRNS-1 I1 = MYSENDSET(NPRTRNS,MYSETW,JA) I2 = MYRECVSET(NPRTRNS,MYSETW,JA) DO JA1=1,NPRTRNS-1 IF(MYSENDSET(NPRTRNS,MYSETW,JA1) == I2) I3 =MYRECVSET(NPRTRNS,MYSETW,JA1) ENDDO IAUX0 = MAX(D%NLTSFTB(I1),D%NLTSGTB(I2),IAUX0) IAUX1 = MAX(D%NLTSGTB(I2),D%NLTSFTB(I3),IAUX1) ENDDO IAUX0 = MAX(D%NLTSGTB(MYSETW),IAUX0) IAUX1 = MAX(D%NLTSGTB(MYSETW),IAUX1) DO JA=1,NPRTRNS+1 D%NSTAGT0B(JA) = (JA-1)*IAUX0 D%NSTAGT1B(JA) = (JA-1)*IAUX1 ENDDO D%NLENGT0B = IAUX0*NPRTRNS D%NLENGT1B = IAUX1*NPRTRNS ENDIF ! GRIDPOINT SPACE ALLOCATE(D%NFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NFRSTLAT ',SIZE(D%NFRSTLAT ),SHAPE(D%NFRSTLAT ) ALLOCATE(D%NLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NLSTLAT ',SIZE(D%NLSTLAT ),SHAPE(D%NLSTLAT ) ALLOCATE(D%NPTRLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLAT ',SIZE(D%NPTRLAT ),SHAPE(D%NPTRLAT ) ALLOCATE(D%NPTRFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRFRSTLAT',SIZE(D%NPTRFRSTLAT),SHAPE(D%NPTRFRSTLAT) ALLOCATE(D%NPTRLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9)'D%NPTRLSTLAT',SIZE(D%NPTRLSTLAT),SHAPE(D%NPTRLSTLAT) ALLOCATE(D%LSPLITLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%LSPLITLAT',SIZE(D%LSPLITLAT),SHAPE(D%LSPLITLAT) ALLOCATE(D%NPROCA_GP(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCA_GP',SIZE(D%NPROCA_GP),SHAPE(D%NPROCA_GP) IF(.NOT.D%LWEIGHTED_DISTR) THEN ALLOCATE(ZDUM(1)) CALL SUEMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT, LEQ_REGIONS,& & D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& & D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& & ZDUM,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& & IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN,RALD%NDGUX) ELSE CALL SUEMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT, LEQ_REGIONS,& & D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& & D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& & D%RWEIGHT,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& & IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN,RALD%NDGUX) ENDIF D%NDGL_GP = D%NLSTLAT(MY_REGION_NS)-D%NFRSTLOFF IF (LLP1) THEN IF(.NOT.D%LGRIDONLY) THEN WRITE(NOUT,FMT='(/'' OUTPUT FROM ROUTINE SUEMPLAT: ''/)') WRITE(NOUT,FMT='('' D%NULTPP '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NULTPP(1:NPRTRNS) WRITE(NOUT,FMT='('' D%NPROCL '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPROCL(1:R%NDGL) ENDIF WRITE(NOUT,FMT='('' D%NFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NFRSTLOFF D%NPTRFLOFF '')') WRITE(NOUT,FMT='(2(1X,I6))') D%NFRSTLOFF, D%NPTRFLOFF WRITE(NOUT,FMT='('' D%NPTRLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%LSPLITLAT '')') WRITE(NOUT,FMT='(50(1X,L1))') D%LSPLITLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%NPTRFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NPTRLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='(/)') ENDIF ALLOCATE(D%NSTA(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NSTA ',SIZE(D%NSTA ),SHAPE(D%NSTA ) ALLOCATE(D%NONL(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NONL ',SIZE(D%NONL ),SHAPE(D%NONL ) IF(.NOT.D%LWEIGHTED_DISTR) THEN CALL SUESTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,ZDUM,ZMEDIAP,D%NPROCA_GP) ELSE CALL SUESTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,D%RWEIGHT,ZMEDIAP,D%NPROCA_GP) ENDIF ! IGPTOTL is the number of grid points in each individual processor ALLOCATE(IGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IGPTOTL(:,:)=0 DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) IGPTOT = 0 DO JGL=D%NPTRFRSTLAT(JA),D%NPTRLSTLAT(JA) IGPTOT = IGPTOT+D%NONL(JGL,JB) ENDDO IGPTOTL(JA,JB) = IGPTOT ENDDO ENDDO D%NGPTOT = IGPTOTL(MY_REGION_NS,MY_REGION_EW) D%NGPTOTMX = MAXVAL(IGPTOTL) D%NGPTOTG = SUM(IGPTOTL) ALLOCATE(D%NGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NGPTOTL ',SIZE(D%NGPTOTL ),SHAPE(D%NGPTOTL ) D%NGPTOTL(:,:) = IGPTOTL(:,:) IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NSTAGTF(D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGTF ',SIZE(D%NSTAGTF ),SHAPE(D%NSTAGTF ) IOFF = 0 DO JGL=1,D%NDGL_FS D%NSTAGTF(JGL) = IOFF IGL = D%NPTRLS(MYSETW) + JGL - 1 IOFF = IOFF + G%NLOEN(IGL)+3+R%NNOEXTZL ENDDO D%NLENGTF = IOFF ENDIF IF(ALLOCATED(ZDUM)) DEALLOCATE(ZDUM) DEALLOCATE(IGPTOTL) IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_MOD:SUEMP_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUEMP_TRANS END MODULE SUEMP_TRANS_MOD ectrans-1.8.0/src/etrans/cpu/internal/espnorm_ctl_mod.F900000664000175000017500000000424215174631767023520 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESPNORM_CTL_MOD CONTAINS SUBROUTINE ESPNORM_CTL(PSPEC,KFLD,KFLD_G,KVSET,KMASTER,PMET,PNORM) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, MYSETV, MYPROC USE ESPNORMD_MOD ,ONLY : ESPNORMD USE SPNORMC_MOD ,ONLY : SPNORMC USE TPMALD_DIM ,ONLY : RALD ! IMPLICIT NONE REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PNORM(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFLD,KFLD_G INTEGER(KIND=JPIM) :: IVSET(KFLD_G) REAL(KIND=JPRB) :: ZMET(0:R%NSPEC_G) REAL(KIND=JPRB) :: ZSM(KFLD,D%NUMP) REAL(KIND=JPRB) :: ZGM(KFLD_G,0:RALD%NMSMAX) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE1 ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:ESPNORM_CTL',0,ZHOOK_HANDLE) IF(PRESENT(KVSET)) THEN IVSET(:) = KVSET(:) ELSE IVSET(:) = MYSETV ENDIF IF(PRESENT(PMET)) THEN ZMET(:) = PMET(:) ELSE ZMET(:) = 1.0_JPRB ENDIF CALL ESPNORMD(PSPEC,KFLD,ZMET,ZSM) IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:SPNORMC',0,ZHOOK_HANDLE1) CALL SPNORMC(ZSM,KFLD_G,IVSET,KMASTER,RALD%NMSMAX,ZGM) IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:SPNORMC',1,ZHOOK_HANDLE1) IF(MYPROC == KMASTER) THEN PNORM(1:KFLD_G) = SUM(ZGM,DIM=2) PNORM(1:KFLD_G) = SQRT(PNORM(1:KFLD_G)) ENDIF IF (LHOOK) CALL DR_HOOK('ESPNORM_CTL_MOD:ESPNORM_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESPNORM_CTL END MODULE ESPNORM_CTL_MOD ectrans-1.8.0/src/etrans/cpu/internal/euvtvd_mod.F900000664000175000017500000000774615174631767022524 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EUVTVD_MOD CONTAINS SUBROUTINE EUVTVD(KM,KMLOC,KFIELD,PU,PV,PVOR,PDIV) !**** *EUVTVD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX - calculation part. !** Interface. ! ---------- ! CALL EUVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number ! -------------------- KFIELD - number of fields (levels) ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! 03-03-03 : G. Radnoti: b-level conform mean-wind distribution ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPMALD_GEO ,ONLY : GALD USE TPMALD_DISTR ,ONLY : DALD IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRB), INTENT(IN) :: PU(:,:) REAL(KIND=JPRB), INTENT(IN) :: PV(:,:) REAL(KIND=JPRB), INTENT(OUT):: PVOR(:,:) REAL(KIND=JPRB), INTENT(OUT):: PDIV(:,:) INTEGER(KIND=JPIM) :: II, IN, IR, J, JN REAL(KIND=JPRB) :: ZKM, ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EUVTVD_MOD:EUVTVD',0,ZHOOK_HANDLE) !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ ZKM=REAL(KM,JPRB)*GALD%EXWN ! Initialize to zero what would not get assigned in Loop 1, ! but is accessed in Loop 2! PDIV(R%NDGL+R%NNOEXTZG:,:)=0 PVOR(R%NDGL+R%NNOEXTZG:,:)=0 ! Loop 1 DO J=1,KFIELD IR=2*J-1 II=IR+1 ! Warning, this loop does not initialize the entire array! DO JN=1,R%NDGL+R%NNOEXTZG PDIV(JN,IR)=-ZKM*PU(JN,II) PDIV(JN,II)= ZKM*PU(JN,IR) PVOR(JN,IR)=-ZKM*PV(JN,II) PVOR(JN,II)= ZKM*PV(JN,IR) ENDDO ENDDO ! Loop 2 DO J=1,2*KFIELD DO JN=1,DALD%NCPL2M(KM),2 IN=(JN-1)/2 ZIN=REAL(IN,JPRB)*GALD%EYWN PVOR(JN,J )=PVOR(JN ,J)+ZIN*PU(JN+1,J) PVOR(JN+1,J)=PVOR(JN+1,J)-ZIN*PU(JN ,J) PDIV(JN,J )=PDIV(JN ,J)-ZIN*PV(JN+1,J) PDIV(JN+1,J)=PDIV(JN+1,J)+ZIN*PV(JN ,J) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EUVTVD_MOD:EUVTVD',1,ZHOOK_HANDLE) END SUBROUTINE EUVTVD END MODULE EUVTVD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eftdirad_mod.F900000664000175000017500000000577215174631767022766 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFTDIRAD_MOD CONTAINS SUBROUTINE EFTDIRAD(PREEL,KFIELDS,KGL) !**** *EFTDIRAD - Direct Fourier transform ! Purpose. Routine for Grid-point to Fourier transform - adjoint ! -------- !** Interface. ! ---------- ! CALL EFTDIRAD(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELDS - number of fields ! Method. ! ------- ! Externals. FFT992 - FFT routine ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! R. El Khatib 01-Sep-2015 support for FFTW transforms ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DISTR ,ONLY : D, MYSETW !USE TPM_TRANS USE TPM_GEOMETRY ,ONLY : G #ifdef WITH_FFT992 USE TPM_FFT ,ONLY : T USE TPMALD_FFT , ONLY : TALD #endif USE TPM_FFTW ,ONLY : TW, EXEC_FFTW USE TPM_DIM ,ONLY : R USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL REAL(KIND=JPRB), INTENT(INOUT) :: PREEL(:,:) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE REAL(KIND=JPRB) :: ZNORM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EFTDIRAD_MOD:EFTDIRAD',0,ZHOOK_HANDLE) ITYPE = 1 IJUMP = 1 IGLG = D%NPTRLS(MYSETW)+KGL-1 ILOEN = G%NLOEN(IGLG) IST = 2*(G%NMEN(IGLG)+1)+1 ILEN = ILOEN+3-IST IOFF = D%NSTAGTF(KGL)+1 DO JJ=1,ILEN DO JF=1,KFIELDS PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB ENDDO ENDDO DO JJ=1,1 DO JF=1,KFIELDS PREEL(JF,IOFF-1+JJ) = 2.0_JPRB * PREEL(JF,IOFF-1+JJ) ENDDO ENDDO #ifdef WITH_FFT992 IF( TALD%LFFT992 )THEN CALL FFT992(PREEL(1,IOFF),T%TRIGS(1,KGL),& &T%NFAX(1,KGL),KFIELDS,IJUMP,ILOEN,KFIELDS,ITYPE) ELSE #endif IRLEN=G%NLOEN(IGLG)+R%NNOEXTZL ICLEN=(IRLEN/2+1)*2 CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) #ifdef WITH_FFT992 ENDIF #endif ! Change of metric (not in forward routine) ZNORM=1.0_JPRB/(2.0_JPRB*REAL(ILOEN,JPRB)) DO JJ=1,ILOEN DO JF=1,KFIELDS PREEL(JF,IOFF-1+JJ) = ZNORM * PREEL(JF,IOFF-1+JJ) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EFTDIRAD_MOD:EFTDIRAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFTDIRAD END MODULE EFTDIRAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eupdspbad_mod.F900000664000175000017500000000751315174631767023146 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EUPDSPBAD_MOD CONTAINS SUBROUTINE EUPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) !**** *EUPDSPBAD* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update spectral arrays for a fixed zonal wave-number ! from values in POA. !** Interface. ! ---------- ! CALL EUPDSPBAD(....) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFIELD - number of fields ! POA - work array ! PSPEC - spectral array ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the ! first and last field ! L. Isaksen : 95-06-06 Reordering of spectral arrays ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DIM !USE TPM_FIELDS !USE TPM_DISTR USE TPMALD_DISTR ,ONLY : DALD ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELD REAL(KIND=JPRB) ,INTENT(OUT) :: POA(:,:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN,IFLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 0. NOTE. ! ----- ! The following transfer reads : ! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) ! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) ! with n from m to NSMAX ! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. ! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) ! nn is the loop index. ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EUPDSPBAD_MOD:EUPDSPBAD',0,ZHOOK_HANDLE) POA(:,:) = 0.0_JPRB IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELD IR= 2*JFLD-1 II=IR+1 IFLD = KFLDPTR(JFLD) !DIR$ IVDEP !OCL NOVREC DO JN=1,DALD%NCPL2M(KM),2 INM=DALD%NESM0(KM)+(JN-1)*2 POA(JN,IR) = PSPEC(IFLD,INM) POA(JN+1,IR) = PSPEC(IFLD,INM+1) POA(JN,II) = PSPEC(IFLD,INM+2) POA(JN+1,II) = PSPEC(IFLD,INM+3) PSPEC(IFLD,INM )= 0.0_JPRB PSPEC(IFLD,INM+1)= 0.0_JPRB PSPEC(IFLD,INM+2)= 0.0_JPRB PSPEC(IFLD,INM+3)= 0.0_JPRB ENDDO ENDDO ELSE DO JN=1,DALD%NCPL2M(KM),2 INM=DALD%NESM0(KM)+(JN-1)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELD IR= 2*JFLD-1 II=IR+1 POA(JN,IR) = PSPEC(JFLD,INM) POA(JN+1,IR) = PSPEC(JFLD,INM+1) POA(JN,II) = PSPEC(JFLD,INM+2) POA(JN+1,II) = PSPEC(JFLD,INM+3) PSPEC(JFLD,INM )= 0.0_JPRB PSPEC(JFLD,INM+1)= 0.0_JPRB PSPEC(JFLD,INM+2)= 0.0_JPRB PSPEC(JFLD,INM+3)= 0.0_JPRB ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('EUPDSPBAD_MOD:EUPDSPBAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EUPDSPBAD END MODULE EUPDSPBAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eftinvad_mod.F900000664000175000017500000000607315174631767022777 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFTINVAD_MOD CONTAINS SUBROUTINE EFTINVAD(PREEL,KFIELDS,KGL) !**** *EFTINVAD - Inverse Fourier transform - adjoint ! Purpose. Routine for Fourier to Grid-point transform ! -------- !** Interface. ! ---------- ! CALL EFTINVAD(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELDS - number of fields ! Method. ! ------- ! Externals. FFT992 - FFT routine ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 01-Sep-2015 support for FFTW transforms ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G #ifdef WITH_FFT992 USE TPM_FFT ,ONLY : T USE TPMALD_FFT, ONLY :: TALD #endif USE TPM_FFTW ,ONLY : TW, EXEC_FFTW USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL REAL(KIND=JPRB), INTENT(OUT) :: PREEL(:,:) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,IJUMP,JJ,JF,ILOEN INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE REAL(KIND=JPRB) :: ZNORM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EFTINVAD_MOD:EFTINVAD',0,ZHOOK_HANDLE) ITYPE =-1 IJUMP = 1 IGLG = D%NPTRLS(MYSETW)+KGL-1 ILOEN = G%NLOEN(IGLG)+R%NNOEXTZL IST = 2*(G%NMEN(IGLG)+1)+1 ILEN = ILOEN+3-IST IOFF = D%NSTAGTF(KGL)+1 ! ! Change of metric (not in forward routine) #ifdef WITH_FFT992 IF( TALD%LFFT992 )THEN CALL FFT992(PREEL(1,IOFF),T%TRIGS(1,KGL),& &T%NFAX(1,KGL),KFIELDS,IJUMP,ILOEN,KFIELDS,ITYPE) ELSE #endif IRLEN=G%NLOEN(IGLG)+R%NNOEXTZL ICLEN=(IRLEN/2+1)*2 CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) #ifdef WITH_FFT992 ENDIF #endif ZNORM=2.0_JPRB*REAL(ILOEN,JPRB) DO JJ=1,1 DO JF=1,KFIELDS PREEL(JF,IOFF-1+JJ) = (ZNORM/2.0_JPRB) * PREEL(JF,IOFF-1+JJ) ENDDO ENDDO DO JJ=3,ILOEN+1 DO JF=1,KFIELDS PREEL(JF,IOFF-1+JJ) = ZNORM * PREEL(JF,IOFF-1+JJ) ENDDO ENDDO DO JJ=1,ILEN DO JF=1,KFIELDS PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EFTINVAD_MOD:EFTINVAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFTINVAD END MODULE EFTINVAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/evdtuvad_comm_mod.F900000664000175000017500000001155315174631767024033 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EVDTUVAD_COMM_MOD CONTAINS SUBROUTINE EVDTUVAD_COMM(KM,KMLOC,KFIELD,KFLDPTR,PSPMEANU,PSPMEANV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM USE TPM_FIELDS USE TPM_DISTR USE TPMALD_FIELDS USE TPMALD_GEO USE TPMALD_DISTR USE MPL_MODULE USE ABORT_TRANS_MOD USE SET2PE_MOD !**** *EVDTUVAD_COMM* - Compute U,V in spectral space ! Purpose. ! -------- ! In Laplace space communicate the mean winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL EVDTUVAD_COMM(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! KFLDPTR - fields pointers ! PEPSNM - REPSNM for wavenumber KM (input-c) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUVAD in IFS CY22R1 ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! 01-Dec-2004 A. Deckmyn Fix mean wind for NPRTRW > 1 ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + ! thread-safety ! R. El Khatib 12-Jan-2020 Fix missing finalization of communications ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM, KFIELD, KMLOC INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) REAL(KIND=JPRB), OPTIONAL, INTENT(OUT) :: PSPMEANU(:),PSPMEANV(:) INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, IFLD INTEGER(KIND=JPIM) :: IN INTEGER(KIND=JPIM) :: ISND, JA, ITAG, ILEN INTEGER(KIND=JPIM) :: ISENDREQ(NPRTRW) REAL(KIND=JPRB) :: ZSPU(2*KFIELD) REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EVDTUVAD_COMM_MOD:EVDTUVAD_COMM',0,ZHOOK_HANDLE) IF (NPRTRW > 1 .AND. KFIELD > 0) THEN IF (KM == 0) THEN IF (PRESENT(KFLDPTR)) THEN DO J=1,KFIELD IFLD=KFLDPTR(J) ZSPU(J)=PSPMEANU(IFLD) ZSPU(KFIELD+J)=PSPMEANV(IFLD) ENDDO ELSE DO J=1,KFIELD ZSPU(J)=PSPMEANU(J) ZSPU(KFIELD+J)=PSPMEANV(J) ENDDO ENDIF DO JA=1,NPRTRW IF (JA /= MYSETW) THEN CALL SET2PE(ISND,0,0,JA,MYSETV) ISND=NPRCIDS(ISND) ITAG=300000+KFIELD*NPROC+ISND CALL MPL_SEND(ZSPU(1:2*KFIELD),KDEST=ISND,KTAG=ITAG, & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JA), & & CDSTRING='EVDTUVAD_COMM:') ENDIF ENDDO ELSE IF (KMLOC == 1) THEN IF (D%NPROCM(0) /= MYSETW) THEN CALL SET2PE(ISND,0,0,D%NPROCM(0),MYSETV) ISND=NPRCIDS(ISND) ITAG=300000+KFIELD*NPROC+MYPROC CALL MPL_RECV(ZSPU(1:2*KFIELD),KSOURCE=ISND,KTAG=ITAG,KOUNT=ILEN,CDSTRING='EVDTUVAD_COMM:') IF (ILEN /= 2*KFIELD) THEN CALL ABORT_TRANS('EVDTUVAD_COMM: RECV INVALID RECEIVE MESSAGE LENGTH') ENDIF IF (PRESENT(KFLDPTR)) THEN DO J=1,KFIELD IFLD=KFLDPTR(J) PSPMEANU(IFLD)=ZSPU(J) PSPMEANV(IFLD)=ZSPU(KFIELD+J) ENDDO ELSE DO J=1,KFIELD PSPMEANU(J)=ZSPU(J) PSPMEANV(J)=ZSPU(KFIELD+J) ENDDO ENDIF ENDIF ENDIF ENDIF IF (KM == 0) THEN DO JA=1,NPRTRW IF (JA /= MYSETW) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(JA),CDSTRING='EUVTVDAD_COMM:') ENDIF ENDDO ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('EVDTUVAD_COMM_MOD:EVDTUVAD_COMM',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EVDTUVAD_COMM END MODULE EVDTUVAD_COMM_MOD ectrans-1.8.0/src/etrans/cpu/internal/easre1bad_mod.F900000664000175000017500000000632315174631767023024 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EASRE1BAD_MOD CONTAINS SUBROUTINE EASRE1BAD(KFC,KM,KMLOC,PIA) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_TRANS ,ONLY : FOUBUF_IN USE TPM_DISTR ,ONLY : D !**** *EASRE1BAD* - Recombine antisymmetric and symmetric parts - adjoint ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *EASRE1BAD(..) ! Explicit arguments : ! ------------------- KFC - number of fields (input-c) ! KM - zonal wavenumber(input-c) ! KMLOC - local version of KM (input-c) ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM (input) ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM (input) ! Implicit arguments : FOUBUF_IN - output buffer (output) ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1BAD in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! R. El Khatib 26-Aug-2021 Optimizations ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC REAL(KIND=JPRB), INTENT(OUT) :: PIA(RALD%NDGLSUR+R%NNOEXTZG,KFC) INTEGER(KIND=JPIM) :: JFLD, JGL ,IPROC INTEGER(KIND=JPIM) :: IISTAN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. ! --------------------------------------------------- IF (LHOOK) CALL DR_HOOK('EASRE1BAD_MOD:EASRE1BAD',0,ZHOOK_HANDLE) #ifdef __INTEL_COMPILER !$OMP SIMD PRIVATE(JGL) DO JFLD =1,KFC DO JGL=1,R%NDGL PIA(JGL,JFLD)=FOUBUF_IN((D%NSTAGT0B(D%NPROCL(JGL))+D%NPNTGTB1(KMLOC,JGL))*KFC+JFLD) ENDDO ENDDO #else DO JGL=1,R%NDGL IPROC=D%NPROCL(JGL) DO JFLD =1,KFC IISTAN=(D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*KFC PIA(JGL,JFLD)=FOUBUF_IN(IISTAN+JFLD) ENDDO ENDDO #endif IF (LHOOK) CALL DR_HOOK('EASRE1BAD_MOD:EASRE1BAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EASRE1BAD END MODULE EASRE1BAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/espnsdead_mod.F900000664000175000017500000000605515174631767023145 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESPNSDEAD_MOD CONTAINS SUBROUTINE ESPNSDEAD(KM,KF_SCALARS,PF,PNSD) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_GEN !USE TPM_DIM !USE TPM_FIELDS !USE TPM_TRANS USE TPMALD_DISTR ,ONLY : DALD USE TPMALD_GEO ,ONLY : GALD !**** *ESPNSDEAD* - Compute North-South derivative in spectral space ! Purpose. ! -------- ! In Laplace space compute the the North-south derivative !** Interface. ! ---------- ! CALL ESPNSDEAD(...) ! Explicit arguments : ! -------------------- ! KM -zonal wavenumber (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PF (NLEI1,2*KF_SCALARS) - input field (input) ! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : YOMLAP ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From SPNSDEAD in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB), INTENT(INOUT) :: PF(:,:) REAL(KIND=JPRB), INTENT(IN) :: PNSD(:,:) INTEGER(KIND=JPIM) :: ISKIP, J, JN INTEGER(KIND=JPIM) :: IN REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. COMPUTE NORTH SOUTH DERIVATIVE. ! ------------------------------- !* 1.1 COMPUTE IF (LHOOK) CALL DR_HOOK('ESPNSDEAD_MOD:ESPNSDEAD',0,ZHOOK_HANDLE) IF(KM == 0) THEN ISKIP = 1 ELSE ISKIP = 1 ENDIF DO JN=1,DALD%NCPL2M(KM),2 IN = (JN-1)/2 ZIN = REAL(IN,JPRB)*GALD%EYWN DO J=1,2*KF_SCALARS,ISKIP PF(JN+1,J) = PF(JN+1,J)-ZIN*PNSD(JN ,J) PF(JN ,J) = PF(JN ,J)+ZIN*PNSD(JN+1,J) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('ESPNSDEAD_MOD:ESPNSDEAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESPNSDEAD END MODULE ESPNSDEAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eftdir_ctlad_mod.F900000664000175000017500000001351515174631767023622 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFTDIR_CTLAD_MOD CONTAINS SUBROUTINE EFTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB, & & KVSETUV,KVSETSC,KPTRGP,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *EFTDIR_CTLAD - Direct Fourier transform control - adjoint ! Purpose. Control routine for Grid-point to Fourier transform ! -------- !** Interface. ! ---------- ! CALL EFTDIR_CTLAD(..) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! PGP - gridpoint array ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fields in gridpoint space ! Method. ! ------- ! Externals. TRGTOL - transposition routine ! ---------- FOURIER_OUT - copy fourier data to Fourier buffer ! EFTDIRAD - fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 ! 19-11-01 G. Radnoti bug correction by introducing CPL_INT interface ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! R. El Khatib 05-03-15 remove HLOMP ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D USE TRLTOG_MOD ,ONLY : TRLTOG USE FOURIER_OUTAD_MOD ,ONLY : FOURIER_OUTAD USE EFTDIRAD_MOD ,ONLY : EFTDIRAD ! IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB 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) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP2(:,:,:) ! Local variables REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER :: ZGTF(:,:) INTEGER(KIND=JPIM) :: IST INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: JGL,IGL,J1,J2 INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Field distribution in Spectral/Fourier space IF (LHOOK) CALL DR_HOOK('EFTDIR_CTLAD_MOD:EFTDIR_CTLAD',0,ZHOOK_HANDLE) CALL GSTATS(133,0) IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ZGTF => ZGTF_HEAP(:,:) ENDIF ZGTF(:,:)=0._JPRB IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IVSETSC(:) = -1 ENDIF IST = 1 IF(KF_UV_G > 0) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF CALL GSTATS(1642,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) DO JGL=1,D%NDGL_FS IGL = JGL CALL FOURIER_OUTAD(ZGTF,KF_FS,IGL) ! Fourier transform IF(KF_FS>0) THEN CALL EFTDIRAD(ZGTF,KF_FS,IGL) ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1642,1) CALL GSTATS(133,1) ! Transposition CALL GSTATS(183,0) IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:) = -1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) DO J3=1,UBOUND(PGP3A,3) IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) DO J3=1,UBOUND(PGP3B,3) IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(183,1) IF (LHOOK) CALL DR_HOOK('EFTDIR_CTLAD_MOD:EFTDIR_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFTDIR_CTLAD END MODULE EFTDIR_CTLAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/evdtuv_mod.F900000664000175000017500000000771215174631767022515 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EVDTUV_MOD CONTAINS SUBROUTINE EVDTUV(KM,KFIELD,KFLDPTR,PVOR,PDIV,PU,PV,PSPMEANU,PSPMEANV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DIM !USE TPM_FIELDS USE TPMALD_FIELDS ,ONLY : FALD USE TPMALD_GEO ,ONLY : GALD USE TPMALD_DISTR ,ONLY : DALD !**** *VDTUV* - Compute U,V in spectral space ! Purpose. ! -------- ! In Laplace space compute the the winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL VDTUV(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! KFLDPTR - fields pointers ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PVOR(NLEI1,2*KFIELD) - vorticity (input) ! PDIV(NLEI1,2*KFIELD) - divergence (input) ! PU(NLEI1,2*KFIELD) - u wind (output) ! PV(NLEI1,2*KFIELD) - v wind (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUV in IFS CY22R1 ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM, KFIELD REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:),PDIV(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PU (:,:),PV (:,:) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) REAL(KIND=JPRB), OPTIONAL, INTENT(IN) :: PSPMEANU(:),PSPMEANV(:) INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, IN, IFLD REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('EVDTUV_MOD:EVDTUV',0,ZHOOK_HANDLE) ZKM=REAL(KM,JPRB)*GALD%EXWN DO J=1,2*KFIELD DO JN=1,DALD%NCPL2M(KM),2 IN = (JN-1)/2 ZIN = REAL(IN,JPRB)*GALD%EYWN PU(JN ,J) = -ZIN*PVOR(JN+1,J) PU(JN+1,J) = ZIN*PVOR(JN,J) PV(JN ,J) = -ZIN*PDIV(JN+1,J) PV(JN+1,J) = ZIN*PDIV(JN,J) ENDDO ENDDO DO J=1,KFIELD IR = 2*J-1 II = IR+1 DO JN=1,DALD%NCPL2M(KM) IJ=(JN-1)/2 PU(JN,IR)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*(-ZKM*PDIV(JN,II)-PU(JN,IR)) PU(JN,II)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*( ZKM*PDIV(JN,IR)-PU(JN,II)) PV(JN,IR)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*(-ZKM*PVOR(JN,II)+PV(JN,IR)) PV(JN,II)= FALD%RLEPINM(DALD%NPME(KM)+IJ)*( ZKM*PVOR(JN,IR)+PV(JN,II)) ENDDO ENDDO IF (KM == 0) THEN IF (PRESENT(KFLDPTR)) THEN DO J = 1, KFIELD IR = 2*J-1 IFLD=KFLDPTR(J) PU(1,IR)=PSPMEANU(IFLD) PV(1,IR)=PSPMEANV(IFLD) ENDDO ELSE DO J = 1, KFIELD IR = 2*J-1 PU(1,IR)=PSPMEANU(J) PV(1,IR)=PSPMEANV(J) ENDDO ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('EVDTUV_MOD:EVDTUV',1,ZHOOK_HANDLE) END SUBROUTINE EVDTUV END MODULE EVDTUV_MOD ectrans-1.8.0/src/etrans/cpu/internal/eprfi2_mod.F900000664000175000017500000000615215174631767022364 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI2_MOD CONTAINS SUBROUTINE EPRFI2(KM,KMLOC,KF_FS,PFFT) !**** *EPRFI2* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *EPRFI2(..) ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAIA - antisymmetric part of Fourier ! components for KM (output) ! PSIA - symmetric part of Fourier ! components for KM (output) ! Implicit arguments : The Grid point arrays of the model. ! -------------------- ! Method. ! ------- ! Externals. PRFI2B - basic copying routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-25 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 93-03-19 D. Giard - CDCONF='T' ! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' ! Modified : 93-05-13 D. Giard - correction of the previous bug ! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK !USE TPM_TRANS USE EPRFI2B_MOD ,ONLY : EPRFI2B ! IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KM INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS REAL(KIND=JPRB) , INTENT(OUT) :: PFFT(:,:) ! ------------------------------------------------------------------ !* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. ! ------------------------------------------- CALL EPRFI2B(KF_FS,KM,KMLOC,PFFT) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI2 END MODULE EPRFI2_MOD ectrans-1.8.0/src/etrans/cpu/internal/eupdspad_mod.F900000664000175000017500000001107215174631767022777 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EUPDSPAD_MOD CONTAINS SUBROUTINE EUPDSPAD(KM,KF_UV,KF_SCALARS,PFFT,PVODI, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) !**** *EUPDSPAD* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update the spectral arrays for a fixed zonal wave-number ! from values in POA1 and POA2. !** Interface. ! ---------- ! CALL EUPDSPAD(...) ! Explicit arguments : ! -------------------- ! KM - zonal wave-number ! POA1 - spectral fields for zonal wavenumber KM (basic var.) ! POA2 - spectral fields for zonal wavenumber KM (vor. div.) ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Externals. UPDSPADB - basic transfer routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 94-08-02 R. El Khatib - interface to UPDSPADB ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DIM USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B !USE TPM_DISTR USE EUPDSPBAD_MOD ,ONLY : EUPDSPBAD ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV,KF_SCALARS REAL(KIND=JPRB) , INTENT(OUT) :: PFFT(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PVODI(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND INTEGER(KIND=JPIM) :: IDIM1,IDIM3,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. UPDATE FIELDS ! ------------- !* 1.1 VORTICITY AND DIVERGENCE. IF (LHOOK) CALL DR_HOOK('EUPDSPAD_MOD:EUPDSPAD',0,ZHOOK_HANDLE) IST = 1 IF (KF_UV > 0) THEN IST = IST+4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV CALL EUPDSPBAD(KM,KF_UV,PVODI(:,IVORS:IVORE),PSPVOR,KFLDPTRUV) CALL EUPDSPBAD(KM,KF_UV,PVODI(:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) ENDIF !* 1.2 SCALARS IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IEND = IST+2*KF_SCALARS-1 CALL EUPDSPBAD(KM,KF_SCALARS,PFFT(:,IST:IEND),PSPSCALAR,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IDIM1 = NF_SC2 IEND = IST+2*IDIM1-1 CALL EUPDSPBAD(KM,IDIM1,PFFT(:,IST:IEND),PSPSC2) IST=IST+2*IDIM1 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL EUPDSPBAD(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3A(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL EUPDSPBAD(KM,IDIM1,PFFT(:,IST:IEND),PSPSC3B(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('EUPDSPAD_MOD:EUPDSPAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EUPDSPAD END MODULE EUPDSPAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eltinv_ctl_mod.F900000664000175000017500000001055415174631767023341 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTINV_CTL_MOD CONTAINS SUBROUTINE ELTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2,& & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV,FSPGL_PROC) !**** *ELTINV_CTL* - Control routine for inverse Legandre transform. ! Purpose. ! -------- ! Control routine for the inverse LEGENDRE transform !** Interface. ! ---------- ! CALL EINV_TRANS_CTL(...) ! KF_OUT_LT - number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! KFLDPTRUV(:) - field pointer array for vor./div. ! KFLDPTRSC(:) - field pointer array for PSPSCALAR ! FSPGL_PROC - external procedure to be executed in fourier space ! before transposition ! Method. ! ------- ! Externals. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-06-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! O.Spaniel Oct-2004 phasing for AL29 ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : LALLOPERM !USE TPM_DIM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE ELTINV_MOD ,ONLY : ELTINV USE TRMTOL_MOD ,ONLY : TRMTOL ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILEI2,IDIM1 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ELTINV_CTL_MOD:ELTINV_CTL',0,ZHOOK_HANDLE) ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS IDIM1 = 2*KF_OUT_LT IBLEN = D%NLENGT0B*2*KF_OUT_LT IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) FOUBUF(1)=0._JPRB ! to force allocation here ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) FOUBUF(1)=0._JPRB ! to force allocation here ENDIF IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! to force allocation here ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! to force allocation here ENDIF IF(KF_OUT_LT > 0) THEN CALL GSTATS(1647,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL ELTINV(IM,JM,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,& & PSPVOR,PSPDIV,PSPSCALAR ,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1647,1) ENDIF CALL GSTATS(152,0) CALL TRMTOL(FOUBUF_IN,FOUBUF,2*KF_OUT_LT) CALL GSTATS(152,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) IF (LHOOK) CALL DR_HOOK('ELTINV_CTL_MOD:ELTINV_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTINV_CTL END MODULE ELTINV_CTL_MOD ectrans-1.8.0/src/etrans/cpu/internal/eltinv_mod.F900000664000175000017500000001567715174631767022512 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTINV_MOD CONTAINS SUBROUTINE ELTINV(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC,PSPMEANU,PSPMEANV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B USE TPMALD_DIM ,ONLY : RALD USE EPRFI1B_MOD ,ONLY : EPRFI1B USE EVDTUV_MOD ,ONLY : EVDTUV USE ESPNSDE_MOD ,ONLY : ESPNSDE USE ELEINV_MOD ,ONLY : ELEINV USE EASRE1B_MOD ,ONLY : EASRE1B USE FSPGL_INT_MOD ,ONLY : FSPGL_INT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !**** *LTINV* - Inverse Legendre transform ! Purpose. ! -------- ! Tranform from Laplace space to Fourier space, compute U and V ! and north/south derivatives of state variables. !** Interface. ! ---------- ! *CALL* *LTINV(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : The Laplace arrays of the model. ! -------------------- The values of the Legendre polynomials ! The grid point arrays of the model ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1B - prepares the spectral fields ! VDTUV - compute u and v from vorticity and divergence ! SPNSDE - compute north-south derivatives ! LEINV - Inverse Legendre transform ! ASRE1 - recombination of symmetric/antisymmetric part ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINV in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 26-Aug-2021 Optimization for EASRE1B ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 INTEGER(KIND=JPIM), INTENT(IN) :: KDIM1 REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB) :: ZIA(RALD%NDGLSUR+R%NNOEXTZG,KLEI2) INTEGER(KIND=JPIM) :: IFC, ISTA INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU INTEGER(KIND=JPIM) :: IFIRST, ILAST,IDIM1,IDIM3,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- IF (LHOOK) CALL DR_HOOK('ELTINV_MOD:ELTINV',0,ZHOOK_HANDLE) IFIRST = 1 ILAST = 4*KF_UV ZIA=0.0_JPRB IF (KF_UV > 0) THEN IVORL = 1 IVORU = 2*KF_UV IDIVL = 2*KF_UV+1 IDIVU = 4*KF_UV IUL = 4*KF_UV+1 IUU = 6*KF_UV IVL = 6*KF_UV+1 IVU = 8*KF_UV CALL EPRFI1B(KM,ZIA(:,IVORL:IVORU),PSPVOR,KF_UV,KFLDPTRUV) CALL EPRFI1B(KM,ZIA(:,IDIVL:IDIVU),PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV CALL EVDTUV(KM,KF_UV,KFLDPTRUV,ZIA(:,IVORL:IVORU),ZIA(:,IDIVL:IDIVU),& & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU),PSPMEANU,PSPMEANV) ENDIF IF(KF_SCALARS > 0)THEN IF(PRESENT(PSPSCALAR)) THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IFIRST = ILAST+1 ILAST = IFIRST-1+2*NF_SC2 CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC2(:,:),NF_SC2) ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC3A(:,:,J3),IDIM1) ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL EPRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC3B(:,:,J3),IDIM1) ENDDO ENDIF ENDIF IF(ILAST /= 8*KF_UV+2*KF_SCALARS) THEN WRITE(0,*) 'LTINV:KF_UV,KF_SCALARS,ILAST ',KF_UV,KF_SCALARS,ILAST CALL ABORT_TRANS('LTINV_MOD:ILAST /= 8*KF_UV+2*KF_SCALARS') ENDIF ENDIF IF (KF_SCDERS > 0) THEN ISL = 2*(4*KF_UV)+1 ISU = ISL+2*KF_SCALARS-1 IDL = 2*(4*KF_UV+KF_SCALARS)+1 IDU = IDL+2*KF_SCDERS-1 CALL ESPNSDE(KM,KF_SCALARS,ZIA(:,ISL:ISU),ZIA(:,IDL:IDU)) ENDIF ! ------------------------------------------------------------------ !* 4. INVERSE LEGENDRE TRANSFORM. ! --------------------------- ISTA = 1 IFC = 2*KF_OUT_LT IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN ISTA = ISTA+2*KF_UV ENDIF IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN ISTA = ISTA+2*KF_UV ENDIF CALL ELEINV(KM,IFC,KF_OUT_LT,ZIA(:,ISTA:ISTA+IFC-1)) ! ------------------------------------------------------------------ !* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. ! -------------------------------------------- CALL EASRE1B(IFC,KM,KMLOC,ZIA(:,ISTA:ISTA+IFC-1)) ! ------------------------------------------------------------------ ! 6. OPTIONAL COMPUTATIONS IN FOURIER SPACE IF(PRESENT(FSPGL_PROC)) THEN CALL FSPGL_INT(KM,KMLOC,KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT,FSPGL_PROC,& & KFLDPTRUV,KFLDPTRSC) ENDIF IF (LHOOK) CALL DR_HOOK('ELTINV_MOD:ELTINV',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTINV END MODULE ELTINV_MOD ectrans-1.8.0/src/etrans/cpu/internal/eleinv_mod.F900000664000175000017500000000645415174631767022464 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELEINV_MOD CONTAINS SUBROUTINE ELEINV(KM,KFC,KF_OUT_LT,PIA) !**** *LEINV* - Inverse Legendre transform. ! Purpose. ! -------- ! Inverse Legendre tranform of all variables(kernel). !** Interface. ! ---------- ! CALL LEINV(...) ! Explicit arguments : KM - zonal wavenumber (input-c) ! -------------------- KFC - number of fields to tranform (input-c) ! PIA - spectral fields ! for zonal wavenumber KM (input) ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PLEPO - Legendre polonomials for zonal ! wavenumber KM (input-c) ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - calls SGEMVX (matrix multiply) ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LEINV in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 01-Sep-2015 support for FFTW transforms ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R !USE TPM_GEOMETRY !USE TPM_TRANS USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW USE TPMALD_DIM ,ONLY : RALD #ifdef WITH_FFT992 USE TPMALD_FFT ,ONLY : TALD #endif USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT REAL(KIND=JPRB), INTENT(INOUT) :: PIA(:,:) INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',0,ZHOOK_HANDLE) IF (KFC>0) THEN ITYPE=1 IRLEN=R%NDGL+R%NNOEXTZG ICLEN=RALD%NDGLSUR+R%NNOEXTZG #ifdef WITH_FFT992 IF( TALD%LFFT992 )THEN CALL FFT992(PIA,TALD%TRIGSE,TALD%NFAXE,1,RALD%NDGLSUR+R%NNOEXTZG,IRLEN,KFC,ITYPE) ELSE #endif IOFF=1 CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PIA) #ifdef WITH_FFT992 ENDIF #endif ENDIF IF (LHOOK) CALL DR_HOOK('ELEINV_MOD:ELEINV',1,ZHOOK_HANDLE) END SUBROUTINE ELEINV END MODULE ELEINV_MOD ectrans-1.8.0/src/etrans/cpu/internal/edealloc_resol_mod.F900000664000175000017500000000517515174631767024155 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EDEALLOC_RESOL_MOD CONTAINS SUBROUTINE EDEALLOC_RESOL(KRESOL) !**** *EDEALLOC_RESOL_MOD* - Deallocations of a resolution ! Purpose. ! -------- ! Release allocated arrays for a given resolution !** Interface. ! ---------- ! CALL EDEALLOC_RESOL_MOD ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 from etrans_end ! B. Bochenek (Apr 2015): Phasing: update ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : LENABLED, NOUT USE TPM_DISTR ,ONLY : D USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F #ifdef WITH_FFT992 USE TPM_FFT ,ONLY : T #endif USE TPM_FFTW ,ONLY : TW,DESTROY_PLANS_FFTW USE TPM_FLT ,ONLY : S USE ESET_RESOL_MOD ,ONLY : ESET_RESOL IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KRESOL ! ------------------------------------------------------------------ IF (.NOT.LENABLED(KRESOL)) THEN WRITE(UNIT=NOUT,FMT='('' EDEALLOC_RESOL WARNING: KRESOL = '',I3,'' ALREADY DISABLED '')') KRESOL ELSE CALL ESET_RESOL(KRESOL) !TPM_DISTR DEALLOCATE(D%NFRSTLAT,D%NLSTLAT,D%NPTRLAT,D%NPTRFRSTLAT,D%NPTRLSTLAT) DEALLOCATE(D%LSPLITLAT,D%NSTA,D%NONL,D%NGPTOTL,D%NPROCA_GP) IF(D%LWEIGHTED_DISTR) THEN DEALLOCATE(D%RWEIGHT) ENDIF IF(.NOT.D%LGRIDONLY) THEN DEALLOCATE(D%MYMS,D%NUMPP,D%NPOSSP,D%NPROCM,D%NDIM0G,D%NASM0,D%NATM0) DEALLOCATE(D%NLATLS,D%NLATLE,D%NPMT,D%NPMS,D%NPMG,D%NULTPP,D%NPROCL) DEALLOCATE(D%NPTRLS,D%NALLMS,D%NPTRMS,D%NSTAGT0B,D%NSTAGT1B,D%NPNTGTB0) DEALLOCATE(D%NPNTGTB1,D%NLTSFTB,D%NLTSGTB,D%MSTABF) DEALLOCATE(D%NSTAGTF) #ifdef WITH_FFT992 !TPM_FFT DEALLOCATE(T%TRIGS,T%NFAX) #endif !TPM_FFTW CALL DESTROY_PLANS_FFTW !TPM_GEOMETRY DEALLOCATE(G%NMEN,G%NDGLU) ELSE DEALLOCATE(G%NLOEN) ENDIF LENABLED(KRESOL)=.FALSE. ENDIF ! ------------------------------------------------------------------ END SUBROUTINE EDEALLOC_RESOL END MODULE EDEALLOC_RESOL_MOD ectrans-1.8.0/src/etrans/cpu/internal/eltdirad_mod.F900000664000175000017500000001344215174631767022765 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTDIRAD_MOD CONTAINS SUBROUTINE ELTDIRAD(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE EPRFI2AD_MOD ,ONLY : EPRFI2AD USE ELEDIRAD_MOD ,ONLY : ELEDIRAD USE EUVTVDAD_MOD USE EUPDSPAD_MOD ,ONLY : EUPDSPAD !**** *ELTDIRAD* - Control of Direct Legendre transform step - adjoint ! Purpose. ! -------- ! Tranform from Fourier space to spectral space, compute ! vorticity and divergence. !** Interface. ! ---------- ! *CALL* *ELTDIRAD(...)* ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! EPRFI2AD - prepares the Fourier work arrays for model variables. ! ELEDIRAD - direct Legendre transform ! EUVTVDAD - ! EUPDSPAD - updating of spectral arrays (fields) ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-24 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified 94-04-06 R. El khatib Full-POS implementation ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group : 95-10-01 Support for Distributed Memory version ! K. YESSAD (AUGUST 1996): ! - Legendre transforms for transmission coefficients. ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + ! thread-safety ! ------------------------------------------------------------------ ! IMPLICIT NONE ! INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANV(:) INTEGER(KIND=JPIM) :: IFC INTEGER(KIND=JPIM) :: IUS,IUE,IVS,IVE,IVORS,IVORE,IDIVS,IDIVE REAL(KIND=JPRB) :: ZFFT(RALD%NDGLSUR+R%NNOEXTZG,KLED2) REAL(KIND=JPRB) :: ZVODI(RALD%NDGLSUR+R%NNOEXTZG,MAX(4*KF_UV,1)) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM ! -------------------------------------- IF (LHOOK) CALL DR_HOOK('ELTDIRAD_MOD:ELTDIRAD',0,ZHOOK_HANDLE) ZFFT=0.0_JPRB ZVODI=0.0_JPRB ! ------------------------------------------------------------------ !* 6. UPDATE SPECTRAL ARRAYS. ! ----------------------- CALL EUPDSPAD(KM,KF_UV,KF_SCALARS,ZFFT,ZVODI, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ! ------------------------------------------------------------------ !* 5. COMPUTE VORTICITY AND DIVERGENCE. ! --------------------------------- IF( KF_UV > 0 ) THEN IUS = 1 IUE = 2*KF_UV IVS = 2*KF_UV+1 IVE = 4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV ! SET PART OF ZFFT CONTAINING U AND V TO 0. ZFFT(:,IUS:IVE) = 0.0_JPRB CALL EUVTVDAD(KM,KMLOC,KF_UV,KFLDPTRUV,ZFFT(:,IUS:IUE),ZFFT(:,IVS:IVE),& & ZVODI(:,IVORS:IVORE),ZVODI(:,IDIVS:IDIVE),PSPMEANU,PSPMEANV) ENDIF ! ------------------------------------------------------------------ !* 4. DIRECT LEGENDRE TRANSFORM. ! -------------------------- IFC = 2*KF_FS CALL ELEDIRAD(KM,IFC,KLED2,ZFFT) ! ------------------------------------------------------------------ !* 3. FOURIER SPACE COMPUTATIONS. ! --------------------------- ! ------------------------------------------------------------------ !* 2. PREPARE WORK ARRAYS. ! -------------------- CALL EPRFI2AD(KM,KMLOC,KF_FS,ZFFT) IF (LHOOK) CALL DR_HOOK('ELTDIRAD_MOD:ELTDIRAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTDIRAD END MODULE ELTDIRAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eprfi2ad_mod.F900000664000175000017500000000610515174631767022667 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI2AD_MOD CONTAINS SUBROUTINE EPRFI2AD(KM,KMLOC,KF_FS,PFFT) !**** *EPRFI2AD* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *EPRFI2AD(..) ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAIA - antisymmetric part of Fourier ! components for KM (output) ! PSIA - symmetric part of Fourier ! components for KM (output) ! Implicit arguments : The Grid point arrays of the model. ! -------------------- ! Method. ! ------- ! Externals. EPRFI2BAD - basic copying routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-25 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 93-03-19 D. Giard - CDCONF='T' ! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' ! Modified : 93-05-13 D. Giard - correction of the previous bug ! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE EPRFI2BAD_MOD ,ONLY : EPRFI2BAD ! IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KM INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS REAL(KIND=JPRB) , INTENT(IN) :: PFFT(:,:) ! ------------------------------------------------------------------ !* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. ! ------------------------------------------- CALL EPRFI2BAD(KF_FS,KM,KMLOC,PFFT) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI2AD END MODULE EPRFI2AD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eset_resol_mod.F900000664000175000017500000000464515174631767023346 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESET_RESOL_MOD CONTAINS SUBROUTINE ESET_RESOL(KRESOL) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, MSETUP0, NCUR_RESOL, NMAX_RESOL USE TPM_DIM ,ONLY : R, DIM_RESOL !USE TPM_TRANS USE TPM_DISTR ,ONLY : D, DISTR_RESOL USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL #ifdef WITH_FFT992 USE TPM_FFT ,ONLY : T, FFT_RESOL #endif USE TPM_FFTW ,ONLY : TW, FFTW_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL USE TPMALD_DISTR ,ONLY : DALD, ALDDISTR_RESOL #ifdef WITH_FFT992 USE TPMALD_FFT ,ONLY : TALD, ALDFFT_RESOL #endif USE TPMALD_FIELDS ,ONLY : FALD, ALDFIELDS_RESOL USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL ! Local varaibles INTEGER(KIND=JPIM) :: IRESOL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESET_RESOL_MOD:ESET_RESOL',0,ZHOOK_HANDLE) IF(MSETUP0 == 0) CALL ABORT_TRANS('ESET_RESOL:TRANS NOT SETUP') IRESOL = 1 IF(PRESENT(KRESOL)) THEN IRESOL = KRESOL IF(KRESOL < 1 .OR. KRESOL > NMAX_RESOL) THEN WRITE(NOUT,*)'ESET_RESOL: UNKNOWN RESOLUTION ',KRESOL,NMAX_RESOL CALL ABORT_TRANS('ESET_RESOL:KRESOL < 1 .OR. KRESOL > NMAX_RESOL') ENDIF ENDIF IF(IRESOL /= NCUR_RESOL) THEN NCUR_RESOL = IRESOL R => DIM_RESOL(NCUR_RESOL) F => FIELDS_RESOL(NCUR_RESOL) G => GEOM_RESOL(NCUR_RESOL) D => DISTR_RESOL(NCUR_RESOL) #ifdef WITH_FFT992 T => FFT_RESOL(NCUR_RESOL) #endif TW => FFTW_RESOL(NCUR_RESOL) RALD => ALDDIM_RESOL(NCUR_RESOL) DALD => ALDDISTR_RESOL(NCUR_RESOL) #ifdef WITH_FFT992 TALD => ALDFFT_RESOL(NCUR_RESOL) #endif FALD => ALDFIELDS_RESOL(NCUR_RESOL) GALD => ALDGEO_RESOL(NCUR_RESOL) ENDIF IF (LHOOK) CALL DR_HOOK('ESET_RESOL_MOD:ESET_RESOL',1,ZHOOK_HANDLE) END SUBROUTINE ESET_RESOL END MODULE ESET_RESOL_MOD ectrans-1.8.0/src/etrans/cpu/internal/eftinv_ctl_mod.F900000664000175000017500000002043415174631767023331 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFTINV_CTL_MOD CONTAINS SUBROUTINE EFTINV_CTL(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *EFTINV_CTL - Inverse Fourier transform control ! Purpose. Control routine for Fourier to Gridpoint transform ! -------- !** Interface. ! ---------- ! CALL EFTINV_CTL(..) ! Explicit arguments : ! -------------------- ! PGP - gridpoint array ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fi3elds in gridpoint space ! Method. ! ------- ! Externals. TRLTOG - transposition routine ! ---------- FOURIER_IN - copy fourier data from Fourier buffer ! FTINV - fourier transform ! FSC - Fourier space computations ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Hello : 03-10-14 old way of calling ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! O.Spaniel Oct-2004 phasing for AL29 ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP USE TPM_DISTR ,ONLY : D USE FOURIER_IN_MOD ,ONLY : FOURIER_IN USE EFSC_MOD ,ONLY : EFSC USE FTINV_MOD ,ONLY : FTINV USE TRLTOG_MOD ,ONLY : TRLTOG USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT 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) :: KPTRGP(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER :: ZGTF(:,:) REAL(KIND=JPRB),TARGET :: ZDUM(1,D%NLENGTF) REAL(KIND=JPRB),POINTER :: ZUV(:,:) REAL(KIND=JPRB),POINTER :: ZSCALAR(:,:) REAL(KIND=JPRB),POINTER :: ZNSDERS(:,:) REAL(KIND=JPRB),POINTER :: ZEWDERS(:,:) REAL(KIND=JPRB),POINTER :: ZUVDERS(:,:) INTEGER(KIND=JPIM) :: IST INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! 1. Copy Fourier data to local array IF (LHOOK) CALL DR_HOOK('EFTINV_CTL_MOD:EFTINV_CTL',0,ZHOOK_HANDLE) CALL GSTATS(107,0) IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ! Now, force the OS to allocate this shared array right now, not when it starts ! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN ZGTF_HEAP(1,1)=HUGE(1._JPRB) ENDIF ZGTF => ZGTF_HEAP(:,:) ENDIF IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN IST = 1 IF(LVORGP) THEN IST = IST+KF_UV ENDIF IF(LDIVGP) THEN IST = IST+KF_UV ENDIF ZUV => ZGTF(IST:IST+2*KF_UV-1,:) IST = IST+2*KF_UV ZSCALAR => ZGTF(IST:IST+KF_SCALARS-1,:) IST = IST+KF_SCALARS ZNSDERS => ZGTF(IST:IST+KF_SCDERS-1,:) IST = IST+KF_SCDERS IF(LUVDER) THEN ZUVDERS => ZGTF(IST:IST+2*KF_UV-1,:) IST = IST+2*KF_UV ELSE ZUVDERS => ZDUM(1:1,:) ENDIF IF(KF_SCDERS > 0) THEN ZEWDERS => ZGTF(IST:IST+KF_SCDERS-1,:) ELSE ZEWDERS => ZDUM(1:1,:) ENDIF ENDIF CALL GSTATS(1639,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) DO JGL=1,D%NDGL_FS IGL = JGL CALL FOURIER_IN(ZGTF,KF_OUT_LT,IGL) ! 2. Fourier space computations IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN CALL EFSC(IGL,KF_UV,KF_SCALARS,KF_SCDERS,& & ZUV,ZSCALAR,ZNSDERS,ZEWDERS,ZUVDERS) ENDIF ! 3. Fourier transform IF(KF_FS > 0) THEN CALL FTINV(ZGTF,KF_FS,IGL) ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1639,1) IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN NULLIFY(ZUV) NULLIFY(ZSCALAR) NULLIFY(ZNSDERS) NULLIFY(ZUVDERS) NULLIFY(ZEWDERS) ENDIF CALL GSTATS(107,1) ! 4. Transposition IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:)=-1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSEIF(PRESENT(KVSETSC2).OR.PRESENT(KVSETSC3A)& & .OR.PRESENT(KVSETSC3B)) THEN IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) IGP3APAR=UBOUND(PGP3A,3) IF(LSCDERS) IGP3APAR=IGP3APAR/3 DO J3=1,IGP3APAR IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) IGP3BPAR=UBOUND(PGP3B,3) IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 DO J3=1,IGP3BPAR IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF IF(IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN WRITE(NERR,*)'FTINV:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G CALL ABORT_TRANS('FTINV_CTL_MOD:IOFF /= KF_SCALARS_G') ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IF( LVORGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF( LDIVGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G IF(LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF IF(KF_UV_G > 0 .AND. LUVDER) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IF(LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF CALL GSTATS(157,0) CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(157,1) IF (LHOOK) CALL DR_HOOK('EFTINV_CTL_MOD:EFTINV_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFTINV_CTL END MODULE EFTINV_CTL_MOD ectrans-1.8.0/src/etrans/cpu/internal/eltinv_ctlad_mod.F900000664000175000017500000000776315174631767023656 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTINV_CTLAD_MOD CONTAINS SUBROUTINE ELTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2,& & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) !**** *ELTINV_CTLAD* - Control routine for inverse Legandre transform - adj. ! Purpose. ! -------- ! Control routine for the inverse LEGENDRE transform !** Interface. ! ---------- ! CALL EINV_TRANS_CTL(...) ! KF_OUT_LT - number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! KFLDPTRUV(:) - field pointer array for vor./div. ! KFLDPTRSC(:) - field pointer array for PSPSCALAR ! Method. ! ------- ! Externals. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-06-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! O.Spaniel Oct-2004 phasing for AL29 ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + ! thread-safety ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : LALLOPERM !USE TPM_DIM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE ELTINVAD_MOD ,ONLY : ELTINVAD USE TRLTOM_MOD ,ONLY : TRLTOM ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCDERS 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(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANV(:) INTEGER(KIND=JPIM) :: IBLEN, ILEI2 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ELTINV_CTLAD_MOD:ELTINV_CTLAD',0,ZHOOK_HANDLE) ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS IBLEN = D%NLENGT0B*2*KF_OUT_LT IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! force allocation here ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! force allocation here ENDIF CALL GSTATS(180,0) CALL TRLTOM(FOUBUF,FOUBUF_IN,2*KF_OUT_LT) CALL GSTATS(180,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) CALL GSTATS(1648,0) IF(KF_OUT_LT > 0) THEN CALL ELTINVAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) ENDIF CALL GSTATS(1648,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) IF (LHOOK) CALL DR_HOOK('ELTINV_CTLAD_MOD:ELTINV_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTINV_CTLAD END MODULE ELTINV_CTLAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/suemp_trans_preleg_mod.F900000664000175000017500000001751715174631767025102 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE SUEMP_TRANS_PRELEG_MOD CONTAINS SUBROUTINE SUEMP_TRANS_PRELEG ! Set up distributed environment for the transform package (part 1) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRW, NPRTRV, MYSETW USE TPMALD_DISTR ,ONLY : DALD USE TPMALD_DIM ,ONLY : RALD USE TPMALD_FIELDS ,ONLY : FALD USE TPMALD_GEO ,ONLY : GALD !USE SUWAVEDI_MOD !USE ABORT_TRANS_MOD IMPLICIT NONE INTEGER(KIND=JPIM) :: JA,JM,JMLOC,JW,JV,ILATPP,IRESTL,IMLOC,IDT,INM,JN,IM,ILAST LOGICAL :: LLP1,LLP2 INTEGER(KIND=JPIM) :: ISPEC(NPRTRW),IMYMS(RALD%NMSMAX+1),IKNTMP(0:RALD%NMSMAX) INTEGER(KIND=JPIM) :: IKMTMP(0:R%NSMAX),ISPEC2P INTEGER(KIND=JPIM) :: IC(NPRTRW) INTEGER(KIND=JPIM) :: IMDIM,IL,IND,IK,IPOS,IKM REAL(KIND=JPRB) :: ZLEPDIM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_PRELEG_MOD:SUEMP_TRANS_PRELEG',0,ZHOOK_HANDLE) IF(.NOT.D%LGRIDONLY) THEN LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEMP_TRANS_PRELEG ===' !* 1. Initialize partitioning of wave numbers to PEs ! ! ---------------------------------------------- ALLOCATE(D%NASM0(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NASM0 ',SIZE(D%NASM0 ),SHAPE(D%NASM0 ) ALLOCATE(DALD%NESM0(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'DALD%NESM0 ',SIZE(DALD%NESM0 ),SHAPE(DALD%NESM0 ) ALLOCATE(D%NATM0(0:R%NTMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NATM0 ',SIZE(D%NATM0 ),SHAPE(D%NATM0 ) ALLOCATE(D%NUMPP(NPRTRW)) IF(LLP2)WRITE(NOUT,9) 'D%NUMPP ',SIZE(D%NUMPP ),SHAPE(D%NUMPP ) ALLOCATE(D%NPOSSP(NPRTRW+1)) IF(LLP2)WRITE(NOUT,9) 'D%NPOSSP',SIZE(D%NPOSSP ),SHAPE(D%NPOSSP ) ALLOCATE(D%NPROCM(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCM',SIZE(D%NPROCM ),SHAPE(D%NPROCM ) ALLOCATE(DALD%NPME(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'DALD%NPME',SIZE(DALD%NPME),SHAPE(DALD%NPME) ALLOCATE(DALD%NCPL2M(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'DALD%NCPL2M',SIZE(DALD%NCPL2M),SHAPE(DALD%NCPL2M) CALL ELLIPS(R%NSMAX,RALD%NMSMAX,IKNTMP,IKMTMP) DALD%NPME(0)=1 DO JM=1,RALD%NMSMAX DALD%NPME(JM)=DALD%NPME(JM-1)+IKNTMP(JM-1)+1 ENDDO DO JM=0,RALD%NMSMAX DALD%NCPL2M(JM) = 2*(IKNTMP(JM)+1) ENDDO ALLOCATE(FALD%RLEPINM(R%NSPEC_G/2)) IF(LLP2)WRITE(NOUT,9) 'FALD%RLEPINM',SIZE(FALD%RLEPINM),SHAPE(FALD%RLEPINM) DO JM=0,RALD%NMSMAX DO JN=1,IKNTMP(JM) ZLEPDIM=-((REAL(JM,JPRB)**2)*(GALD%EXWN**2)+& & (REAL(JN,JPRB)**2)*(GALD%EYWN**2)) FALD%RLEPINM(DALD%NPME(JM)+JN)=1./ZLEPDIM ENDDO ENDDO DO JM=1,RALD%NMSMAX ZLEPDIM=-(REAL(JM,JPRB)**2)*(GALD%EXWN**2) FALD%RLEPINM(DALD%NPME(JM))=1./ZLEPDIM ENDDO FALD%RLEPINM(DALD%NPME(0))=0. D%NUMPP(:) = 0 ISPEC(:) = 0 DALD%NESM0(:)=-99 IMDIM = 0 IL = 1 IND = 1 IK = 0 IPOS = 1 DO JM=0,RALD%NMSMAX IK = IK + IND IF (IK > NPRTRW) THEN IK = NPRTRW IND = -1 ELSEIF (IK < 1) THEN IK = 1 IND = 1 ENDIF IKM =DALD%NCPL2M(JM)/2 -1 D%NPROCM(JM) = IK ISPEC(IK) = ISPEC(IK)+IKM+1 D%NUMPP(IK) = D%NUMPP(IK)+1 IF (IK == MYSETW) THEN IMDIM = IMDIM + IKM+1 IMYMS(IL) = JM DALD%NESM0(JM) = IPOS IPOS = IPOS+(IKM+1)*4 IL = IL+1 ENDIF ENDDO D%NPOSSP(1) = 1 ISPEC2P = 4*ISPEC(1) D%NSPEC2MX = ISPEC2P DO JA=2,NPRTRW D%NPOSSP(JA) = D%NPOSSP(JA-1)+ISPEC2P ISPEC2P = 4*ISPEC(JA) D%NSPEC2MX=MAX(D%NSPEC2MX,ISPEC2P) ENDDO D%NPOSSP(NPRTRW+1) = D%NPOSSP(NPRTRW)+ISPEC2P D%NSPEC2 = 4*IMDIM D%NSPEC=D%NSPEC2 D%NUMP = D%NUMPP (MYSETW) ALLOCATE(D%MYMS(D%NUMP)) IF(LLP2)WRITE(NOUT,9) 'D%MYMS ',SIZE(D%MYMS ),SHAPE(D%MYMS ) D%MYMS(:) = IMYMS(1:D%NUMP) D%NUMTP = D%NUMP ! pointer to the first wave number of a given wave-set in NALLMS array ALLOCATE(D%NPTRMS(NPRTRW)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRMS ',SIZE(D%NPTRMS ),SHAPE(D%NPTRMS ) D%NPTRMS(:) = 1 DO JA=2,NPRTRW D%NPTRMS(JA) = D%NPTRMS(JA-1)+D%NUMPP(JA-1) ENDDO ! D%NALLMS : wave numbers for all wave-set concatenated together to give all ! wave numbers in wave-set order. ALLOCATE(D%NALLMS(RALD%NMSMAX+1)) IF(LLP2)WRITE(NOUT,9) 'D%NALLMS ',SIZE(D%NALLMS ),SHAPE(D%NALLMS ) IC(:) = 0 DO JM=0,RALD%NMSMAX D%NALLMS(IC(D%NPROCM(JM))+D%NPTRMS(D%NPROCM(JM))) = JM IC(D%NPROCM(JM)) = IC(D%NPROCM(JM))+1 ENDDO ALLOCATE(D%NDIM0G(0:RALD%NMSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NDIM0G ',SIZE(D%NDIM0G ),SHAPE(D%NDIM0G ) IPOS = 1 DO JA=1,NPRTRW DO JMLOC=1,D%NUMPP(JA) IM = D%NALLMS(D%NPTRMS(JA)+JMLOC-1) D%NDIM0G(IM) = IPOS IPOS = IPOS+2*DALD%NCPL2M(IM) ENDDO ENDDO ALLOCATE(D%NLATLS(NPRTRW,NPRTRV)) IF(LLP2)WRITE(NOUT,9) 'D%NLATLS',SIZE(D%NLATLS ),SHAPE(D%NLATLS ) ALLOCATE(D%NLATLE(NPRTRW,NPRTRV)) IF(LLP2)WRITE(NOUT,9) 'D%NLATLE',SIZE(D%NLATLE ),SHAPE(D%NLATLE ) D%NLATLS(:,:) = 9999 D%NLATLE(:,:) = -1 ILATPP = R%NDGL/NPRTRW IRESTL = R%NDGL-NPRTRW*ILATPP DO JW=1,NPRTRW IF (JW > IRESTL) THEN D%NLATLS(JW,1) = IRESTL*(ILATPP+1)+(JA-IRESTL-1)*ILATPP+1 D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP-1 ELSE D%NLATLS(JW,1) = (JA-1)*(ILATPP+1)+1 D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP ENDIF ENDDO ILAST=0 DO JW=1,NPRTRW ILATPP = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)/NPRTRV IRESTL = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)-NPRTRV*ILATPP DO JV=1,NPRTRV IF (JV > IRESTL) THEN D%NLATLS(JW,JV) = IRESTL*(ILATPP+1)+(JV-IRESTL-1)*ILATPP+1+ILAST D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP-1 ELSE D%NLATLS(JW,JV) = (JV-1)*(ILATPP+1)+1+ILAST D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP ENDIF ENDDO ILAST=D%NLATLE(JW,NPRTRV) ENDDO IF (LLP1) THEN DO JW=1,NPRTRW DO JV=1,NPRTRV WRITE(NOUT,'(" JW=",I6," JV=",I6," D%NLATLS=",I6," D%NLATLE=",I6)')& & JW,JV,D%NLATLS(JW,JV),D%NLATLE(JW,JV) ENDDO ENDDO ENDIF ALLOCATE(D%NPMT(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMT ',SIZE(D%NPMT ),SHAPE(D%NPMT ) ALLOCATE(D%NPMS(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMS ',SIZE(D%NPMS ),SHAPE(D%NPMS ) ALLOCATE(D%NPMG(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMG ',SIZE(D%NPMG ),SHAPE(D%NPMG ) IDT = R%NTMAX-R%NSMAX INM = 0 DO JMLOC=1,D%NUMP IMLOC = D%MYMS(JMLOC) INM = INM+R%NTMAX+2-IMLOC ENDDO INM = 0 DO JM=0,R%NSMAX INM = INM+R%NTMAX+2-JM ENDDO D%NLEI3D = (R%NLEI3-1)/NPRTRW+1 ENDIF IF (LHOOK) CALL DR_HOOK('SUEMP_TRANS_PRELEG_MOD:SUEMP_TRANS_PRELEG',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUEMP_TRANS_PRELEG END MODULE SUEMP_TRANS_PRELEG_MOD ectrans-1.8.0/src/etrans/cpu/internal/eftinv_ctlad_mod.F900000664000175000017500000002123215174631767023633 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFTINV_CTLAD_MOD CONTAINS SUBROUTINE EFTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *EFTINV_CTLAD - Inverse Fourier transform control - adjoint ! Purpose. Control routine for Fourier to Gridpoint transform ! -------- !** Interface. ! ---------- ! CALL EFTINV_CTLAD(..) ! Explicit arguments : ! -------------------- ! PGP - gridpoint array ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fi3elds in gridpoint space ! Method. ! ------- ! Externals. TRLTOG - transposition routine ! ---------- FOURIER_IN - copy fourier data from Fourier buffer ! FTINV - fourier transform ! FSC - Fourier space computations ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF, LDIVGP, LSCDERS, LUVDER, LVORGP USE TPM_DISTR ,ONLY : D USE FOURIER_INAD_MOD ,ONLY : FOURIER_INAD USE EFSCAD_MOD ,ONLY : EFSCAD USE EFTINVAD_MOD ,ONLY : EFTINVAD USE TRGTOL_MOD ,ONLY : TRGTOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE EXTPER_MOD ,ONLY : EXTPER ! IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT 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) :: KPTRGP(:) 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(:,:,:) ! ------------------------------------------------------------------ REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER :: ZGTF(:,:) REAL(KIND=JPRB),TARGET :: ZDUM(1,D%NLENGTF) REAL(KIND=JPRB),POINTER :: ZUV(:,:) REAL(KIND=JPRB),POINTER :: ZSCALAR(:,:) REAL(KIND=JPRB),POINTER :: ZNSDERS(:,:) REAL(KIND=JPRB),POINTER :: ZEWDERS(:,:) REAL(KIND=JPRB),POINTER :: ZUVDERS(:,:) INTEGER(KIND=JPIM) :: IST, IBLEN INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! 4. Transposition IF (LHOOK) CALL DR_HOOK('EFTINV_CTLAD_MOD:EFTINV_CTLAD',0,ZHOOK_HANDLE) IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ZGTF => ZGTF_HEAP(:,:) ENDIF ZGTF(:,:)=0._JPRB IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:)=-1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSEIF(PRESENT(KVSETSC2).OR.PRESENT(KVSETSC3A)& & .OR.PRESENT(KVSETSC3B)) THEN IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) IGP3APAR=UBOUND(PGP3A,3) IF(LSCDERS) IGP3APAR=IGP3APAR/3 DO J3=1,IGP3APAR IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) IGP3BPAR=UBOUND(PGP3B,3) IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 DO J3=1,IGP3BPAR IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF IF(IOFF /= KF_SCALARS_G ) THEN WRITE(NERR,*)'FTINV_CTLAD:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G CALL ABORT_TRANS('FTINV_CTLAD_MOD:IOFF /= KF_SCALARS_G') ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IF( LVORGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF( LDIVGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G IF(LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF IF(KF_UV_G > 0 .AND. LUVDER) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IF(LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF CALL GSTATS(182,0) CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(182,1) ! Periodization of auxiliary fields in x direction IF(R%NNOEXTZL>0) THEN CALL EXTPER(ZGTF,R%NDLON+R%NNOEXTZL,1,R%NDLON,KF_FS,D%NDGL_FS,INT(D%NSTAGTF,KIND=JPIM),0) ENDIF ! 3. Fourier transform IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN IST = 1 IF(LVORGP) THEN IST = IST+KF_UV ENDIF IF(LDIVGP) THEN IST = IST+KF_UV ENDIF ZUV => ZGTF(IST:IST+2*KF_UV-1,:) IST = IST+2*KF_UV ZSCALAR => ZGTF(IST:IST+KF_SCALARS-1,:) IST = IST+KF_SCALARS ZNSDERS => ZGTF(IST:IST+KF_SCDERS-1,:) IST = IST+KF_SCDERS IF(LUVDER) THEN ZUVDERS => ZGTF(IST:IST+2*KF_UV-1,:) IST = IST+2*KF_UV ELSE ZUVDERS => ZDUM(1:1,:) ENDIF IF(KF_SCDERS > 0) THEN ZEWDERS => ZGTF(IST:IST+KF_SCDERS-1,:) ELSE ZEWDERS => ZDUM(1:1,:) ENDIF ENDIF IBLEN = D%NLENGT0B*2*KF_OUT_LT IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) FOUBUF(1)=0._JPRB ! force allocation here ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) FOUBUF(1)=0._JPRB ! force allocation here ENDIF CALL GSTATS(132,0) CALL GSTATS(1641,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) DO JGL=1,D%NDGL_FS IGL = JGL IF(KF_FS > 0) THEN CALL EFTINVAD(ZGTF,KF_FS,IGL) ENDIF ! 2. Fourier space computations IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN CALL EFSCAD(IGL,KF_UV,KF_SCALARS,KF_SCDERS,& & ZUV,ZSCALAR,ZNSDERS,ZEWDERS,ZUVDERS) ENDIF ! 1. Copy Fourier data to local array CALL FOURIER_INAD(ZGTF,KF_OUT_LT,IGL) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1641,1) IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN NULLIFY(ZUV) NULLIFY(ZSCALAR) NULLIFY(ZNSDERS) NULLIFY(ZUVDERS) NULLIFY(ZEWDERS) ENDIF CALL GSTATS(132,1) IF (LHOOK) CALL DR_HOOK('EFTINV_CTLAD_MOD:EFTINV_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFTINV_CTLAD END MODULE EFTINV_CTLAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/efscad_mod.F900000664000175000017500000000670715174631767022430 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFSCAD_MOD CONTAINS SUBROUTINE EFSCAD(KGL,KF_UV,KF_SCALARS,KF_SCDERS,& & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) !**** *EFSCAD - Division by a*cos(theta), east-west derivatives - adjoint ! Purpose. ! -------- ! In Fourier space divide u and v and all north-south ! derivatives by a*cos(theta). Also compute east-west derivatives ! of u,v,thermodynamic, passiv scalar variables and surface ! pressure. !** Interface. ! ---------- ! CALL EFSCAD(..) ! Explicit arguments : PUV - u and v ! -------------------- PSCALAR - scalar valued varaibles ! PNSDERS - N-S derivative of S.V.V. ! PEWDERS - E-W derivative of S.V.V. ! PUVDERS - E-W derivative of u and v ! Method. ! ------- ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 (From SC2FSC) ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_TRANS ,ONLY : LUVDER USE TPM_DISTR ,ONLY : D, MYSETW !USE TPM_FIELDS USE TPM_GEOMETRY ,ONLY : G USE TPMALD_GEO ,ONLY : GALD IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KGL,KF_UV,KF_SCALARS,KF_SCDERS REAL(KIND=JPRB) , INTENT(INOUT) :: PUV(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PSCALAR(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PNSDERS(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PEWDERS(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PUVDERS(:,:) INTEGER(KIND=JPIM) :: IMEN,ISTAGTF INTEGER(KIND=JPIM) :: JF,IGLG,II,IR,JM REAL(KIND=JPRB) :: ZIM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EFSCAD_MOD:EFSCAD',0,ZHOOK_HANDLE) IGLG = D%NPTRLS(MYSETW)+KGL-1 IMEN = G%NMEN(IGLG) ISTAGTF = D%NSTAGTF(KGL) ! ------------------------------------------------------------------ !* 2. EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. IF(LUVDER)THEN DO JM=0,IMEN ZIM=REAL(JM,JPRB)*GALD%EXWN IR = ISTAGTF+2*JM+1 II = IR+1 DO JF=1,2*KF_UV PUV(JF,II) = PUV(JF,II) - ZIM*PUVDERS(JF,IR) PUV(JF,IR) = PUV(JF,IR) + ZIM*PUVDERS(JF,II) PUVDERS(JF,IR) = 0.0_JPRB PUVDERS(JF,II) = 0.0_JPRB ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES IF(KF_SCDERS > 0)THEN DO JM=0,IMEN ZIM=REAL(JM,JPRB)*GALD%EXWN IR = ISTAGTF+2*JM+1 II = IR+1 DO JF=1,KF_SCALARS PSCALAR(JF,II) = PSCALAR(JF,II) - ZIM* PEWDERS(JF,IR) PSCALAR(JF,IR) = PSCALAR(JF,IR) + ZIM* PEWDERS(JF,II) PEWDERS(JF,IR) = 0.0_JPRB PEWDERS(JF,II) = 0.0_JPRB ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('EFSCAD_MOD:EFSCAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFSCAD END MODULE EFSCAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eprfi1_mod.F900000664000175000017500000000665615174631767022374 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI1_MOD CONTAINS SUBROUTINE EPRFI1(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& & KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DISTR !USE TPM_TRANS USE EPRFI1B_MOD ,ONLY : EPRFI1B !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *EPRFI1(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPVOR - vorticity ! PSPDIV - divergence ! PSPSCALAR - scalar variables ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1 in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PIA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! ------------------------------------ IF (LHOOK) CALL DR_HOOK('EPRFI1_MOD:EPRFI1',0,ZHOOK_HANDLE) IFIRST = 1 ILAST = 4*KF_UV !* 1.1 VORTICITY AND DIVERGENCE. IF(KF_UV > 0)THEN IVOR = 1 IDIV = 2*KF_UV+1 CALL EPRFI1B(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) CALL EPRFI1B(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV ENDIF !* 1.2 SCALAR VARIABLES. IF(KF_SCALARS > 0)THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL EPRFI1B(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ENDIF IF (LHOOK) CALL DR_HOOK('EPRFI1_MOD:EPRFI1',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI1 END MODULE EPRFI1_MOD ectrans-1.8.0/src/etrans/cpu/internal/eftdir_ctl_mod.F900000664000175000017500000001511615174631767023314 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFTDIR_CTL_MOD CONTAINS SUBROUTINE EFTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB, & & KVSETUV,KVSETSC,KPTRGP,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,AUX_PROC) !**** *EFTDIR_CTL - Direct Fourier transform control ! Purpose. Control routine for Grid-point to Fourier transform ! -------- !** Interface. ! ---------- ! CALL FTDIR_CTL(..) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_GPB - total global number of output gridpoint fields ! PGP - gridpoint array ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fields in gridpoint space ! Method. ! ------- ! Externals. TRGTOL - transposition routine ! ---------- FOURIER_OUT - copy fourier data to Fourier buffer ! FTDIR - fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti 01-03-13 adaptation to aladin (coupling) ! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 ! 19-11-01 : G. Radnoti bug corection by introducing cpl_int interface ! 02-09-30 : P. Smolikova AUX_PROC for d4 in NH ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF_IN USE TPM_DISTR ,ONLY : D USE TRGTOL_MOD ,ONLY : TRGTOL USE FOURIER_OUT_MOD ,ONLY : FOURIER_OUT USE FTDIR_MOD ,ONLY : FTDIR USE EXTPER_MOD ,ONLY : EXTPER ! IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_GPB INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) 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(:,:,:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC ! Local variables REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER, CONTIGUOUS :: ZGTF(:,:) REAL(KIND=JPRB) :: ZDUM INTEGER(KIND=JPIM) :: IST,INUL,JGL,IGL,IBLEN INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Field distribution in Spectral/Fourier space IF (LHOOK) CALL DR_HOOK('EFTDIR_CTL_MOD:EFTDIR_CTL',0,ZHOOK_HANDLE) IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:) = -1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) DO J3=1,UBOUND(PGP3A,3) IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) DO J3=1,UBOUND(PGP3B,3) IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ! Now, force the OS to allocate this shared array right now, not when it starts ! to be used which is an OPEN-MP loop, that would cause a threads ! synchronization lock : IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN ZGTF_HEAP(1,1)=HUGE(1._JPRB) ENDIF ZGTF => ZGTF_HEAP(:,:) ENDIF ! Transposition CALL GSTATS(158,0) CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(158,1) CALL GSTATS(106,0) ! Periodization of auxiliary fields in x direction IF(R%NNOEXTZL>0) THEN CALL EXTPER(ZGTF,R%NDLON+R%NNOEXTZL,1,R%NDLON,KF_FS,D%NDGL_FS,INT(D%NSTAGTF,KIND=JPIM),0) ELSE IF (PRESENT(AUX_PROC)) THEN CALL AUX_PROC(ZGTF,ZDUM,KF_FS,D%NLENGTF,1,D%NDGL_FS,0,.TRUE.,& & D%NSTAGTF,INUL,INUL,INUL) ENDIF ENDIF ! Fourier transform IBLEN=D%NLENGT0B*2*KF_FS IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! force allocation here ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! force allocation here ENDIF CALL GSTATS(1640,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) DO JGL=1,D%NDGL_FS IGL = JGL IF(KF_FS>0) THEN CALL FTDIR(ZGTF,KF_FS,IGL) ENDIF ! Save Fourier data in FOUBUF_IN CALL FOURIER_OUT(ZGTF,KF_FS,IGL) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1640,1) CALL GSTATS(106,1) IF (LHOOK) CALL DR_HOOK('EFTDIR_CTL_MOD:EFTDIR_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFTDIR_CTL END MODULE EFTDIR_CTL_MOD ectrans-1.8.0/src/etrans/cpu/internal/tpmald_fft.F900000664000175000017500000000156615174631767022462 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE TPMALD_FFT ! Module for Fourier transforms. USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE SAVE TYPE ALDFFT_TYPE REAL(KIND=JPRB) ,POINTER :: TRIGSE(:) ! list of trigonometric function values INTEGER(KIND=JPIM),POINTER :: NFAXE(:) ! list of factors of truncation LOGICAL :: LFFT992=.FALSE. END TYPE ALDFFT_TYPE TYPE(ALDFFT_TYPE),ALLOCATABLE,TARGET :: ALDFFT_RESOL(:) TYPE(ALDFFT_TYPE),POINTER :: TALD END MODULE TPMALD_FFT ectrans-1.8.0/src/etrans/cpu/internal/eltdir_ctl_mod.F900000664000175000017500000001013115174631767023312 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTDIR_CTL_MOD CONTAINS SUBROUTINE ELTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & & PSPVOR,PSPDIV,PSPSCALAR, & & PSPSC3A,PSPSC3B,PSPSC2, & & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV,AUX_PROC) !**** *ELTDIR_CTL* - Control routine for direct Legendre transform ! Purpose. ! -------- ! Direct Legendre transform !** Interface. ! ---------- ! CALL ELTDIR_CTL(...) ! Explicit arguments : ! -------------------- ! KF_FS - number of fields in Fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! KFLDPTRUV(:) - field pointer for vorticity and divergence (input) ! KFLDPTRSC(:) - field pointer for scalarvalued fields (input) ! PSPMEANU(:),PSPMEANV(:) - mean winds ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : LALLOPERM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE ELTDIR_MOD ,ONLY : ELTDIR USE EUVTVD_COMM_MOD , ONLY : EUVTVD_COMM USE TRLTOM_MOD ,ONLY : TRLTOM USE MPL_MODULE IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS 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(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPMEANV(:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2,INUL REAL(KIND=JPRB) :: ZDUM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Transposition from Fourier space distribution to spectral space distribution IF (LHOOK) CALL DR_HOOK('ELTDIR_CTL_MOD:ELTDIR_CTL',0,ZHOOK_HANDLE) IBLEN = D%NLENGT0B*2*KF_FS IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) FOUBUF(1)=0._JPRB ! enforce allocation here ENDIF CALL GSTATS(153,0) CALL TRLTOM(FOUBUF_IN,FOUBUF,2*KF_FS) CALL GSTATS(153,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) ! Periodization of auxiliary fields in y direction IF (PRESENT(AUX_PROC)) THEN CALL AUX_PROC(ZDUM,FOUBUF,2*KF_FS,1,IBLEN,0,D%NUMP,.FALSE.,& & INUL,D%NPROCL,D%NSTAGT0B,D%NPNTGTB1) ENDIF ! Direct Legendre transform ILED2 = 2*KF_FS CALL GSTATS(1645,0) IF (KF_FS>0) THEN !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL ELTDIR(IM,JM,KF_FS,KF_UV,KF_SCALARS,ILED2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) ENDDO !$OMP END PARALLEL DO IF (KF_UV > 0) THEN IF (PRESENT(KFLDPTRUV)) THEN CALL EUVTVD_COMM(KF_UV,PSPMEANU,PSPMEANV,KFLDPTRUV) ELSE CALL EUVTVD_COMM(KF_UV,PSPMEANU,PSPMEANV) ENDIF ENDIF ENDIF CALL GSTATS(1645,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) IF (LHOOK) CALL DR_HOOK('ELTDIR_CTL_MOD:ELTDIR_CTL',1,ZHOOK_HANDLE) ! ----------------------------------------------------------------- END SUBROUTINE ELTDIR_CTL END MODULE ELTDIR_CTL_MOD ectrans-1.8.0/src/etrans/cpu/internal/egath_spec_control_mod.F900000664000175000017500000001414315174631767025036 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EGATH_SPEC_CONTROL_MOD CONTAINS SUBROUTINE EGATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& & KSMAX,KSPEC2,KSPEC2_G,KPOSSP,KDIM0G,KCPL2M,LDZA0IP) !**** *GATH_SPEC_CONTROL* - Gather global spectral array from processors ! Purpose. ! -------- ! Routine for gathering spectral array !** Interface. ! ---------- ! CALL GATH_SPEC_CONTROL(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be distributed ! KTO(:) - Processor responsible for distributing each field ! KVSET(:) - "B-Set" for each field ! PSPEC(:,:) - Local spectral array ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : MTAGDISTSP, NPRCIDS, NPRTRW, MYSETV, MYPROC, NPROC USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE SET2PE_MOD ,ONLY : SET2PE IMPLICIT NONE REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2_G INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) INTEGER(KIND=JPIM) , INTENT(IN) :: KCPL2M(0:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP REAL(KIND=JPRB) :: ZFLD(KSPEC2,KFGATHG) REAL(KIND=JPRB),ALLOCATABLE :: ZRECV(:,:) INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,IBSET,ILEN,JA,ISND INTEGER(KIND=JPIM) :: IRCV,ISP,ILENR,ISTA,ISTP,ISENDREQ(KFGATHG),IPOS0,JNM INTEGER(KIND=JPIM) :: IDIST(KSPEC2_G),IMYFIELDS ! ------------------------------------------------------------------ CALL ABORT_TRANS('EGATH_SPEC_CONTROL:DEAD CODE') !GATHER SPECTRAL ARRAY IF( NPROC == 1 ) THEN CALL GSTATS(1644,0) IF(LDIM1_IS_FLD) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) DO JM=1,KSPEC2_G DO JFLD=1,KFGATHG PSPECG(JFLD,JM) =PSPEC(JFLD,JM) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) DO JFLD=1,KFGATHG DO JM=1,KSPEC2_G PSPECG(JM,JFLD) =PSPEC(JM,JFLD) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1644,1) ELSE IMYFIELDS = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO IF(IMYFIELDS>0) THEN ALLOCATE(ZRECV(KSPEC2_G,IMYFIELDS)) II = 0 CALL GSTATS(1804,0) DO JM=0,KSMAX DO JN=0,KCPL2M(JM)/2-1 IDIST(II+1) = KDIM0G(JM)+4*JN IDIST(II+2) = KDIM0G(JM)+4*JN+1 IDIST(II+3) = KDIM0G(JM)+4*JN+2 IDIST(II+4) = KDIM0G(JM)+4*JN+3 II = II+4 ENDDO ENDDO CALL GSTATS(1804,1) ENDIF CALL GSTATS_BARRIER(788) !Send CALL GSTATS(810,0) IFLDS = 0 IF(KSPEC2 > 0 )THEN DO JFLD=1,KFGATHG IBSET = KVSET(JFLD) IF( IBSET == MYSETV )THEN IFLDS = IFLDS+1 ISND = KTO(JFLD) ITAG = MTAGDISTSP+JFLD+17 IF(LDIM1_IS_FLD) THEN ZFLD(1:KSPEC2,IFLDS)=PSPEC(IFLDS,1:KSPEC2) CALL MPL_SEND(ZFLD(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& &CDSTRING='GATH_SPEC_CONTROL') ELSE CALL MPL_SEND(PSPEC(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& &CDSTRING='GATH_SPEC_CONTROL') ENDIF ENDIF ENDDO ENDIF ! Recieve IFLDR = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IBSET = KVSET(JFLD) IFLDR = IFLDR+1 DO JA=1,NPRTRW ILEN = KPOSSP(JA+1)-KPOSSP(JA) IF( ILEN > 0 )THEN CALL SET2PE(IRCV,0,0,JA,IBSET) ITAG = MTAGDISTSP+JFLD+17 ISTA = KPOSSP(JA) ISTP = ISTA+ILEN-1 CALL MPL_RECV(ZRECV(ISTA:ISTP,IFLDR),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & &CDSTRING='GATH_SPEC_CONTROL') IF( ILENR /= ILEN )THEN WRITE(0,'("GATH_SPEC_CONTROL: JFLD=",I4," JA=",I4," ILEN=",I10," ILENR=",I10)')& &JFLD,JA,ILEN,ILENR CALL ABORT_TRANS('GATH_SPEC_CONTROL:INVALID RECEIVE MESSAGE LENGTH') ENDIF ENDIF ENDDO ENDIF ENDDO ! Check for completion of sends IF(KSPEC2 > 0 )THEN DO JFLD=1,KFGATHG IBSET = KVSET(JFLD) IF( IBSET == MYSETV )THEN CALL MPL_WAIT(ISENDREQ(JFLD), & & CDSTRING='GATH_GRID_CTL: WAIT') ENDIF ENDDO ENDIF CALL GSTATS(810,1) CALL GSTATS_BARRIER2(788) CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JNM,II,JN,ISP) DO JFLD=1,IMYFIELDS IF(LDIM1_IS_FLD) THEN DO JNM=1,KSPEC2_G PSPECG(JFLD,JNM) = ZRECV(IDIST(JNM),JFLD) ENDDO ELSE DO JNM=1,KSPEC2_G PSPECG(JNM,JFLD) = ZRECV(IDIST(JNM),JFLD) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) IF(ALLOCATED(ZRECV)) DEALLOCATE(ZRECV) !Synchronize processors CALL GSTATS(785,0) CALL MPL_BARRIER(CDSTRING='GATH_SPEC_CONTROL:') CALL GSTATS(785,1) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE EGATH_SPEC_CONTROL END MODULE EGATH_SPEC_CONTROL_MOD ectrans-1.8.0/src/etrans/cpu/internal/eleinvad_mod.F900000664000175000017500000000712215174631767022762 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELEINVAD_MOD CONTAINS SUBROUTINE ELEINVAD(KM,KFC,KF_OUT_LT,PIA) !**** *ELEINVAD* - Inverse Legendre transform. ! Purpose. ! -------- ! Inverse Legendre tranform of all variables(kernel). !** Interface. ! ---------- ! CALL ELEINVAD(...) ! Explicit arguments : KM - zonal wavenumber (input-c) ! -------------------- KFC - number of fields to tranform (input-c) ! PIA - spectral fields ! for zonal wavenumber KM (input) ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PLEPO - Legendre polonomials for zonal ! wavenumber KM (input-c) ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - calls SGEMVX (matrix multiply) ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LEINVAD in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 01-Sep-2015 support for FFTW transforms ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R !USE TPM_GEOMETRY !USE TPM_TRANS USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW USE TPMALD_DIM ,ONLY : RALD #ifdef WITH_FFT992 USE TPMALD_FFT ,ONLY : TALD #endif USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT REAL(KIND=JPRB), INTENT(OUT) :: PIA(:,:) INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE INTEGER(KIND=JPIM) :: JJ, JF REAL(KIND=JPRB) :: ZNORM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ELEINVAD_MOD:ELEINVAD',0,ZHOOK_HANDLE) IF (KFC>0) THEN ITYPE=-1 IRLEN=R%NDGL+R%NNOEXTZG ICLEN=RALD%NDGLSUR+R%NNOEXTZG #ifdef WITH_FFT992 IF( TALD%LFFT992 )THEN CALL FFT992(PIA,TALD%TRIGSE,TALD%NFAXE,1,ICLEN,IRLEN,KFC,ITYPE) ELSE #endif IOFF=1 CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PIA) #ifdef WITH_FFT992 ENDIF #endif ZNORM=2.0_JPRB*REAL(R%NDGL+R%NNOEXTZG,JPRB) DO JJ=1,1 DO JF=1,KFC PIA(JJ,JF) = (ZNORM/2.0_JPRB) * PIA(JJ,JF) ENDDO ENDDO DO JJ=3,R%NDGL+R%NNOEXTZG+1 DO JF=1,KFC PIA(JJ,JF) = ZNORM * PIA(JJ,JF) ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('ELEINVAD_MOD:ELEINVAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELEINVAD END MODULE ELEINVAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eprfi2bad_mod.F900000664000175000017500000000606415174631767023035 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI2BAD_MOD CONTAINS SUBROUTINE EPRFI2BAD(KFIELD,KM,KMLOC,PFFT) !**** *EPRFI2BAD* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *EPRFI2BAD(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM ! Implicit arguments : FOUBUF in TPM_TRANS ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 90-07-01 ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R !USE TPMALD_DIM ,ONLY : RALD USE TPM_TRANS ,ONLY : FOUBUF !USE TPM_GEOMETRY USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD,KM,KMLOC REAL(KIND=JPRB) , INTENT(IN) :: PFFT(:,:) INTEGER(KIND=JPIM) :: ISTAN, JF, JGL INTEGER(KIND=JPIM) :: IJR,IJI REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. ! ------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EPRFI2BAD_MOD:EPRFI2BAD',0,ZHOOK_HANDLE) DO JGL=1,R%NDGL ISTAN = (D%NSTAGT1B(D%NPROCL(JGL) )+D%NPNTGTB1(KMLOC,JGL ))*2*KFIELD DO JF =1,KFIELD IJR = 2*(JF-1)+1 IJI = IJR+1 FOUBUF(ISTAN+IJR) = PFFT(JGL,IJR) FOUBUF(ISTAN+IJI) = PFFT(JGL,IJI) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EPRFI2BAD_MOD:EPRFI2BAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI2BAD END MODULE EPRFI2BAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/eledirad_mod.F900000664000175000017500000000731015174631767022743 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELEDIRAD_MOD CONTAINS SUBROUTINE ELEDIRAD(KM,KFC,KLED2,PFFT) !**** *ELEDIRAD* - Direct Legendre transform. ! Purpose. ! -------- ! Direct Legendre tranform of state variables. !** Interface. ! ---------- ! CALL ELEDIRAD(...) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFC - number of field to transform ! PAIA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSIA - symmetric part of Fourier ! fields for zonal wavenumber KM ! POA1 - spectral ! fields for zonal wavenumber KM ! PLEPO - Legendre polonomials ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - matrix multiply ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-01-28 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 93-03-19 D. Giard - NTMAX instead of NSMAX ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib : fix missing support for FFTW ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R !USE TPM_GEOMETRY !USE TPM_TRANS USE TPM_FFTW ,ONLY : TW, EXEC_EFFTW #ifdef WITH_FFT992 USE TPMALD_FFT ,ONLY : TALD #endif USE TPMALD_DIM ,ONLY : RALD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KLED2 REAL(KIND=JPRB), INTENT(INOUT) :: PFFT(:,:) INTEGER(KIND=JPIM) :: IRLEN, ICLEN, IOFF, ITYPE INTEGER(KIND=JPIM) :: JF, JJ REAL(KIND=JPRB) :: ZNORM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ELEDIRAD_MOD:ELEDIRAD',0,ZHOOK_HANDLE) IF (KFC>0) THEN DO JJ=1,1 DO JF=1,KFC PFFT(JJ,JF) = 2.0_JPRB * PFFT(JJ,JF) ENDDO ENDDO ITYPE=1 IRLEN=R%NDGL+R%NNOEXTZG ICLEN=RALD%NDGLSUR+R%NNOEXTZG #ifdef WITH_FFT992 IF( TALD%LFFT992 )THEN CALL FFT992(PFFT,TALD%TRIGSE,TALD%NFAXE,1,RALD%NDGLSUR+R%NNOEXTZG,IRLEN,KFC,ITYPE) ELSEIF ( ASSOCIATED(TW) )THEN #endif IOFF=1 CALL EXEC_EFFTW(ITYPE,IRLEN,ICLEN,IOFF,KFC,TW%LALL_FFTW,PFFT) #ifdef WITH_FFT992 ENDIF #endif ZNORM=1.0_JPRB/(2.0_JPRB*REAL(R%NDGL+R%NNOEXTZG,JPRB)) DO JJ=1,R%NDGL+R%NNOEXTZG DO JF=1,KFC PFFT(JJ,JF) = ZNORM * PFFT(JJ,JF) ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('ELEDIRAD_MOD:ELEDIRAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELEDIRAD END MODULE ELEDIRAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/einv_trans_ctlad_mod.F900000664000175000017500000002455115174631767024517 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EINV_TRANS_CTLAD_MOD CONTAINS SUBROUTINE EINV_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& & KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV) !**** *EINV_TRANS_CTLAD* - Control routine for inverse spectral transform adj. ! Purpose. ! -------- ! Control routine for the inverse spectral transform !** Interface. ! ---------- ! CALL EINV_TRANS_CTLAD(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! 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. ! PGP(:,:,:) - gridpoint fields (output) ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! vorticity : KF_UV_G fields ! divergence : KF_UV_G fields ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! N-S derivative of scalar fields : KF_SCALARS_G fields ! E-W derivative of u : KF_UV_G fields ! E-W derivative of v : KF_UV_G fields ! E-W derivative of scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTINV_CTLAD - control of Legendre transform ! FTINV_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NPROMATR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP !USE TPM_DISTR USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE ELTINV_CTLAD_MOD ,ONLY : ELTINV_CTLAD USE EFTINV_CTLAD_MOD ,ONLY : EFTINV_CTLAD ! IMPLICIT NONE ! Declaration of arguments ! INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS 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(:,:) 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(:) 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(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PMEANV(:) ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Perform transform IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTLAD_MOD:EINV_TRANS_CTLAD',0,ZHOOK_HANDLE) IF_GPB = 2*KF_UV_G+KF_SCALARS_G IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & & KVSETUV,KVSETSC) IBLKS=(IF_GPB-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF(LSCDERS) THEN IF_SCDERS = IF_SCALARS ELSE IF_SCDERS = 0 ENDIF IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS IF(LVORGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF(LDIVGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF_FS = IF_OUT_LT+IF_SCDERS IF(LUVDER) THEN IF_FS = IF_FS+2*IF_UV ENDIF IF_GP = 2*IF_UV_G+IF_SCALARS_G IOFFD = 0 IOFFU = 0 IOFFV = KF_UV_G IOFFUVD = 2*KF_UV_G+KF_SCALARS_G IOFFSC = 2*KF_UV_G IF(LVORGP) THEN IF_GP = IF_GP+IF_UV_G IOFFD = KF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LDIVGP) THEN IF_GP = IF_GP+IF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LSCDERS) THEN IF_GP = IF_GP+2*IF_SCALARS_G IOFFUVD =IOFFUVD+KF_SCALARS_G IOFFSCNS = IOFFSC+KF_SCALARS_G IOFFSCEW = IOFFSC+2*KF_SCALARS_G ENDIF IF(LUVDER) THEN IF_GP = IF_GP+2*IF_UV_G IOFFSCEW = IOFFSCEW+2*KF_UV_G ENDIF DO JFLD=1,IF_UV_G IOFF = 0 IF(LVORGP) THEN IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IF(LDIVGP) THEN IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G+IF_SCALARS_G IF(LSCDERS) THEN IOFF = IOFF+IF_SCALARS_G ENDIF IF(LUVDER) THEN IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_SCALARS_G IOFF = 2*IF_UV_G IF (LVORGP) IOFF = IOFF+IF_UV_G IF (LDIVGP) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LSCDERS) THEN IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LUVDER) THEN IOFF = IOFF+2*IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL EFTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL EFTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL EFTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ENDIF CALL ELTINV_CTLAD(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& & PSPMEANU=PMEANU,PSPMEANV=PMEANV) ENDDO ELSE ! No splitting of fields, transform done in one go CALL EFTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) CALL ELTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& & PSPMEANU=PMEANU,PSPMEANV=PMEANV ) ENDIF IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTLAD_MOD:EINV_TRANS_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EINV_TRANS_CTLAD END MODULE EINV_TRANS_CTLAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/euvtvd_comm_mod.F900000664000175000017500000000743515174631767023532 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EUVTVD_COMM_MOD CONTAINS SUBROUTINE EUVTVD_COMM(KFIELD,PSPMEANU,PSPMEANV,KFLDPTR) !**** *EUVTVD_COMM* - Communicate mean wind ! Purpose. ! -------- !** Interface. ! ---------- ! CALL EUVTVD_COMM(KFIELD,PSPMEANU,PSPMEANV,KFLDPTR) ! Explicit arguments : ! -------------------- KFIELD - number of fields (levels) ! KFLDPTR - fields pointers ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! 03-03-03 : G. Radnoti: b-level conform mean-wind distribution ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! F. Vana + NEC 28-Apr-2009 MPI-OpenMP fix ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement ! R. El Khatib 12-Jan-2020 Fix missing finalization of communications ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM USE TPM_FIELDS USE TPM_DISTR USE TPMALD_GEO USE TPMALD_DISTR USE MPL_MODULE USE SET2PE_MOD USE ABORT_TRANS_MOD IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRB), INTENT(INOUT) :: PSPMEANU(KFIELD) REAL(KIND=JPRB), INTENT(INOUT) :: PSPMEANV(KFIELD) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(KFIELD) INTEGER(KIND=JPIM) :: J, JA,ITAG,ILEN,IFLD,ISND, IM, JM INTEGER(KIND=JPIM) :: ISENDREQ(NPRTRW) REAL(KIND=JPRB) :: ZSPU(2*KFIELD) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EUVTVD_COMM_MOD:EUVTVD_COMM',0,ZHOOK_HANDLE) !* 1. COMMUNICATE MEAN WIND ! --------------------- IF (D%NPROCM(0) == MYSETW) THEN IF (PRESENT(KFLDPTR)) THEN DO J=1,KFIELD IFLD=KFLDPTR(J) ZSPU(J)=PSPMEANU(IFLD) ZSPU(KFIELD+J)=PSPMEANV(IFLD) ENDDO ELSE DO J=1,KFIELD ZSPU(J)=PSPMEANU(J) ZSPU(KFIELD+J)=PSPMEANV(J) ENDDO ENDIF DO JA=1,NPRTRW IF (JA /= MYSETW) THEN CALL SET2PE(ISND,0,0,JA,MYSETV) ISND=NPRCIDS(ISND) ITAG=1 CALL MPL_SEND(ZSPU(1:2*KFIELD),KDEST=ISND,KTAG=ITAG, & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JA),CDSTRING='EUVTVD_COMM:') ENDIF ENDDO DO JA=1,NPRTRW IF (JA /= MYSETW) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(JA),CDSTRING='EUVTVD_COMM:') ENDIF ENDDO ELSE CALL SET2PE(ISND,0,0,D%NPROCM(0),MYSETV) ITAG=1 CALL MPL_RECV(ZSPU(1:2*KFIELD),KSOURCE=NPRCIDS(ISND),KTAG=ITAG,KOUNT=ILEN, CDSTRING='EUVTVD_COMM:') IF (ILEN /= 2*KFIELD) CALL ABORT_TRANS('EUVTVD_COMM: RECV INVALID RECEIVE MESSAGE LENGHT') IF (PRESENT(KFLDPTR)) THEN DO J=1,KFIELD IFLD=KFLDPTR(J) PSPMEANU(IFLD)=ZSPU(J) PSPMEANV(IFLD)=ZSPU(KFIELD+J) ENDDO ELSE DO J=1,KFIELD PSPMEANU(J)=ZSPU(J) PSPMEANV(J)=ZSPU(KFIELD+J) ENDDO ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('EUVTVD_COMM_MOD:EUVTVD_COMM',1,ZHOOK_HANDLE) END SUBROUTINE EUVTVD_COMM END MODULE EUVTVD_COMM_MOD ectrans-1.8.0/src/etrans/cpu/internal/tpmald_geo.F900000664000175000017500000000145215174631767022447 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE TPMALD_GEO ! Module containing data describing plane projection grid. USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE SAVE TYPE ALDGEO_TYPE ! GEOGRAPHY REAL(KIND=JPRB) :: EYWN ! Y-reso REAL(KIND=JPRB) :: EXWN ! X-reso END TYPE ALDGEO_TYPE TYPE(ALDGEO_TYPE),ALLOCATABLE,TARGET :: ALDGEO_RESOL(:) TYPE(ALDGEO_TYPE),POINTER :: GALD END MODULE TPMALD_GEO ectrans-1.8.0/src/etrans/cpu/internal/efsc_mod.F900000664000175000017500000000645115174631767022117 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EFSC_MOD CONTAINS SUBROUTINE EFSC(KGL,KF_UV,KF_SCALARS,KF_SCDERS,& & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) !**** *FSC - Division by a*cos(theta), east-west derivatives ! Purpose. ! -------- ! In Fourier space divide u and v and all north-south ! derivatives by a*cos(theta). Also compute east-west derivatives ! of u,v,thermodynamic, passiv scalar variables and surface ! pressure. !** Interface. ! ---------- ! CALL FSC(..) ! Explicit arguments : PUV - u and v ! -------------------- PSCALAR - scalar valued varaibles ! PNSDERS - N-S derivative of S.V.V. ! PEWDERS - E-W derivative of S.V.V. ! PUVDERS - E-W derivative of u and v ! Method. ! ------- ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 (From SC2FSC) ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_TRANS ,ONLY : LUVDER USE TPM_DISTR ,ONLY : D, MYSETW !USE TPM_FIELDS USE TPM_GEOMETRY ,ONLY : G USE TPMALD_GEO ,ONLY : GALD ! IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KGL,KF_UV,KF_SCALARS,KF_SCDERS REAL(KIND=JPRB) , INTENT(INOUT) :: PUV(:,:) REAL(KIND=JPRB) , INTENT(IN ) :: PSCALAR(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PNSDERS(:,:) REAL(KIND=JPRB) , INTENT( OUT) :: PEWDERS(:,:) REAL(KIND=JPRB) , INTENT( OUT) :: PUVDERS(:,:) INTEGER(KIND=JPIM) :: IMEN,ISTAGTF INTEGER(KIND=JPIM) :: JF,IGLG,II,IR,JM REAL(KIND=JPRB) :: ZIM REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EFSC_MOD:EFSC',0,ZHOOK_HANDLE) IGLG = D%NPTRLS(MYSETW)+KGL-1 IMEN = G%NMEN(IGLG) ISTAGTF = D%NSTAGTF(KGL) ! ------------------------------------------------------------------ !* EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. IF(LUVDER)THEN DO JM=0,IMEN ZIM=REAL(JM,JPRB)*GALD%EXWN IR = ISTAGTF+2*JM+1 II = IR+1 ! use unroll to provoke vectorization of outer loop !cdir unroll=4 DO JF=1,2*KF_UV PUVDERS(JF,IR) = -PUV(JF,II)*ZIM PUVDERS(JF,II) = PUV(JF,IR)*ZIM ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES IF(KF_SCDERS > 0)THEN DO JM=0,IMEN ZIM=REAL(JM,JPRB)*GALD%EXWN IR = ISTAGTF+2*JM+1 II = IR+1 DO JF=1,KF_SCALARS PEWDERS(JF,IR) = -PSCALAR(JF,II)*ZIM PEWDERS(JF,II) = PSCALAR(JF,IR)*ZIM ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('EFSC_MOD:EFSC',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EFSC END MODULE EFSC_MOD ectrans-1.8.0/src/etrans/cpu/internal/edir_trans_ctlad_mod.F900000664000175000017500000001703715174631767024502 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EDIR_TRANS_CTLAD_MOD CONTAINS SUBROUTINE EDIR_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV) !**** *EDIR_TRANS_CTLAD* - Control routine for direct spectral transform-adj. ! Purpose. ! -------- ! Control routine for the direct spectral transform !** Interface. ! ---------- ! CALL EDIR_TRANS_CTLAD(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity ! PSPDIV(:,:) - spectral divergence ! PSPSCALAR(:,:) - spectral scalarvalued fields ! 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. ! PGP(:,:,:) - gridpoint fields ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! ELTDIR_CTLAD - control of Legendre transform ! EFTDIR_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! 01-08-28 : G. Radnoti & R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NPROMATR !USE TPM_TRANS !USE TPM_DISTR USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE ELTDIR_CTLAD_MOD ,ONLY : ELTDIR_CTLAD USE EFTDIR_CTLAD_MOD ,ONLY : EFTDIR_CTLAD IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) 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(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANV(:) ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Perform transform IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTLAD_MOD:EDIR_TRANS_CTLAD',0,ZHOOK_HANDLE) IF_GPB = 2*KF_UV_G+KF_SCALARS_G IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & & KVSETUV,KVSETSC) IBLKS=(IF_GPB-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G DO JFLD=1,IF_UV_G IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDDO DO JFLD=1,IF_SCALARS_G IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO CALL ELTDIR_CTLAD(IF_FS,IF_UV,IF_SCALARS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& & PSPMEANU=PMEANU,PSPMEANV=PMEANV) IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL EFTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL EFTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KPTRGP=IPTRGP,PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL EFTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_GPB,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ENDIF ENDDO ELSE ! No splitting of fields, transform done in one go CALL ELTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& & PSPMEANU=PMEANU,PSPMEANV=PMEANV) CALL EFTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,IF_GPB,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) ENDIF IF (LHOOK) CALL DR_HOOK('EDIR_TRANS_CTLAD_MOD:EDIR_TRANS_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EDIR_TRANS_CTLAD END MODULE EDIR_TRANS_CTLAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/easre1ad_mod.F900000664000175000017500000000525215174631767022662 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EASRE1AD_MOD CONTAINS SUBROUTINE EASRE1AD(KM,KMLOC,KF_OUT_LT,PIA) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_TRANS USE EASRE1BAD_MOD ,ONLY : EASRE1BAD !**** *EASRE1AD* - Recombine antisymmetric and symmetric parts - adjoint ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *EASRE1AD(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (basic ! variables and N-S derivatives) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (basic ! variables and N-S derivatives) ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. EASRE1BAD - basic recombination routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1AD in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KM INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC INTEGER(KIND=JPIM) , INTENT(IN) :: KF_OUT_LT REAL(KIND=JPRB) , INTENT(OUT) :: PIA(:,:) INTEGER(KIND=JPIM) :: IFLDS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EASRE1AD_MOD:EASRE1AD',0,ZHOOK_HANDLE) IFLDS = KF_OUT_LT CALL EASRE1BAD(IFLDS,KM,KMLOC,PIA) IF (LHOOK) CALL DR_HOOK('EASRE1AD_MOD:EASRE1AD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EASRE1AD END MODULE EASRE1AD_MOD ectrans-1.8.0/src/etrans/cpu/internal/espnormd_mod.F900000664000175000017500000000336415174631767023026 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESPNORMD_MOD CONTAINS SUBROUTINE ESPNORMD(PSPEC,KFLD,PMET,PSM) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPMALD_DISTR ,ONLY : DALD ! IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PMET(0:R%NSPEC_G) INTEGER(KIND=JPIM) ,INTENT(IN) :: KFLD REAL(KIND=JPRB) ,INTENT(OUT) :: PSM(:,:) INTEGER(KIND=JPIM) :: JM ,JFLD ,JN ,IM ,ISP INTEGER(KIND=JPIM) :: IN,ISPE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESPNORMD_MOD:ESPNORMD',0,ZHOOK_HANDLE) !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JM,IM,JN,ISP,JFLD,IN,ISPE) DO JM=1,D%NUMP PSM(:,JM) = 0.0_JPRB IM = D%MYMS(JM) IN=DALD%NCPL2M(IM)/2 - 1 DO JN=0,IN ISP=DALD%NESM0(IM) + (JN)*4 ISPE=DALD%NPME (IM) + JN DO JFLD=1,KFLD PSM(JFLD,JM) =PSM(JFLD,JM)& & + PMET(ISPE) *& & ( PSPEC(JFLD,ISP )**2 + PSPEC(JFLD,ISP+1)**2 +& & PSPEC(JFLD,ISP+2)**2 + PSPEC(JFLD,ISP+3)**2 ) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO IF (LHOOK) CALL DR_HOOK('ESPNORMD_MOD:ESPNORMD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESPNORMD END MODULE ESPNORMD_MOD ectrans-1.8.0/src/etrans/cpu/internal/euvtvdad_mod.F900000664000175000017500000001007015174631767023011 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EUVTVDAD_MOD CONTAINS SUBROUTINE EUVTVDAD(KM,KMLOC,KFIELD,KFLDPTR,PU,PV,PVOR,PDIV,PSPMEANU,PSPMEANV) !**** *EUVTVDAD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX. !** Interface. ! ---------- ! CALL EUVTVDAD() ! Explicit arguments : KM - zonal wave-number ! -------------------- KFIELD - number of fields (levels) ! KFLDPTR - fields pointers ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! 03-03-03 G. Radnoti: b-level conform mean wind distribution ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! 01-Dec-2004 A. Deckmyn removed erasing of mean wind ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R !USE TPM_FIELDS USE TPMALD_GEO ,ONLY : GALD USE TPMALD_DISTR ,ONLY : DALD ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD, KM, KMLOC REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:),PDIV(:,:) REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:),PV (:,:) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) REAL(KIND=JPRB), OPTIONAL, INTENT(INOUT) :: PSPMEANU(:),PSPMEANV(:) INTEGER(KIND=JPIM) :: II, IN, IR, J, JN, IFLD REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EUVTVDAD_MOD:EUVTVDAD',0,ZHOOK_HANDLE) IF (KM == 0) THEN IF (PRESENT(KFLDPTR)) THEN DO J=1,KFIELD IR=2*J-1 IFLD=KFLDPTR(J) PU(1,IR)=PSPMEANU(IFLD) PV(1,IR)=PSPMEANV(IFLD) ENDDO ELSE DO J=1,KFIELD IR=2*J-1 PU(1,IR)=PSPMEANU(J) PV(1,IR)=PSPMEANV(J) ENDDO ENDIF ENDIF DO J=1,2*KFIELD DO JN=1,DALD%NCPL2M(KM),2 IN=(JN-1)/2 ZIN=REAL(IN,JPRB)*GALD%EYWN PU(JN+1,J) = PU(JN+1,J) + ZIN * PVOR(JN ,J) PU(JN ,J) = PU(JN ,J) - ZIN * PVOR(JN+1,J) PV(JN+1,J) = PV(JN+1,J) - ZIN * PDIV(JN ,J) PV(JN ,J) = PV(JN ,J) + ZIN * PDIV(JN+1,J) ENDDO ENDDO ZKM=REAL(KM,JPRB)*GALD%EXWN DO J=1,KFIELD IR=2*J-1 II=IR+1 DO JN=1,R%NDGL+R%NNOEXTZG PU(JN,II) = PU(JN,II) - ZKM * PDIV(JN,IR) PU(JN,IR) = PU(JN,IR) + ZKM * PDIV(JN,II) PV(JN,II) = PV(JN,II) - ZKM * PVOR(JN,IR) PV(JN,IR) = PV(JN,IR) + ZKM * PVOR(JN,II) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EUVTVDAD_MOD:EUVTVDAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EUVTVDAD END MODULE EUVTVDAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/espnsde_mod.F900000664000175000017500000000563315174631767022641 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESPNSDE_MOD CONTAINS SUBROUTINE ESPNSDE(KM,KF_SCALARS,PF,PNSD) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_GEN !USE TPM_DIM !USE TPM_FIELDS !USE TPM_TRANS USE TPMALD_DISTR ,ONLY : DALD USE TPMALD_GEO ,ONLY : GALD !**** *SPNSDE* - Compute North-South derivative in spectral space ! Purpose. ! -------- ! In Laplace space compute the the North-south derivative !** Interface. ! ---------- ! CALL SPNSDE(...) ! Explicit arguments : ! -------------------- ! KM -zonal wavenumber (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PF (NLEI1,2*KF_SCALARS) - input field (input) ! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : YOMLAP ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From SPNSDE in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB), INTENT(IN) :: PF(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PNSD(:,:) INTEGER(KIND=JPIM) :: J, JN,IN REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. COMPUTE NORTH SOUTH DERIVATIVE. ! ------------------------------- !* 1.1 COMPUTE IF (LHOOK) CALL DR_HOOK('ESPNSDE_MOD:ESPNSDE',0,ZHOOK_HANDLE) DO JN=1,DALD%NCPL2M(KM),2 IN =(JN-1)/2 ZIN = REAL(IN,JPRB)*GALD%EYWN DO J=1,2*KF_SCALARS PNSD(JN ,J) = -ZIN*PF(JN+1,J) PNSD(JN+1,J) = ZIN*PF(JN,J) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('ESPNSDE_MOD:ESPNSDE',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ESPNSDE END MODULE ESPNSDE_MOD ectrans-1.8.0/src/etrans/cpu/internal/eprfi1ad_mod.F900000664000175000017500000000664015174631767022672 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EPRFI1AD_MOD CONTAINS SUBROUTINE EPRFI1AD(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& & KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DISTR !USE TPM_TRANS USE EPRFI1BAD_MOD ,ONLY : EPRFI1BAD !**** *EPRFI1AD* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *EPRFI1AD(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPVOR - vorticity ! PSPDIV - divergence ! PSPSCALAR - scalar variables ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1AD in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ ! IMPLICIT NONE ! ! INTEGER(KIND=JPIM),INTENT(IN) :: KM,KF_UV,KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) , INTENT(IN) :: PIA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! ------------------------------------ IF (LHOOK) CALL DR_HOOK('EPRFI1AD_MOD:EPRFI1AD',0,ZHOOK_HANDLE) IFIRST = 1 ILAST = 4*KF_UV !* 1.1 VORTICITY AND DIVERGENCE. IF(KF_UV > 0)THEN IVOR = 1 IDIV = 2*KF_UV+1 CALL EPRFI1BAD(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) CALL EPRFI1BAD(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV ENDIF !* 1.2 SCALAR VARIABLES. IF(KF_SCALARS > 0)THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL EPRFI1BAD(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ENDIF IF (LHOOK) CALL DR_HOOK('EPRFI1AD_MOD:EPRFI1AD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EPRFI1AD END MODULE EPRFI1AD_MOD ectrans-1.8.0/src/etrans/cpu/internal/tpmald_tcdis.F900000664000175000017500000000106115174631767022777 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE TPMALD_TCDIS ! useless USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE SAVE REAL(KIND=JPRB) :: TCDIS END MODULE TPMALD_TCDIS ectrans-1.8.0/src/etrans/cpu/internal/tpmald_fields.F900000664000175000017500000000137215174631767023144 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE TPMALD_FIELDS USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE SAVE TYPE ALDFIELDS_TYPE REAL(KIND=JPRB) ,POINTER :: RLEPINM(:) ! eigen-values of the inverse Laplace operator END TYPE ALDFIELDS_TYPE TYPE(ALDFIELDS_TYPE),ALLOCATABLE,TARGET :: ALDFIELDS_RESOL(:) TYPE(ALDFIELDS_TYPE),POINTER :: FALD END MODULE TPMALD_FIELDS ectrans-1.8.0/src/etrans/cpu/internal/cpl_int_mod.F900000664000175000017500000000267515174631767022633 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE CPL_INT_MOD CONTAINS SUBROUTINE CPL_INT(PGTF,KENDROWL,KFIELDS,KFFIELDS,KLEN,KSTA,CPL_PROC,KPTRGP) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KENDROWL INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KFFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KLEN INTEGER(KIND=JPIM), INTENT(IN) :: KSTA(KENDROWL) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB), INTENT(INOUT) :: PGTF(KFIELDS,KLEN) EXTERNAL CPL_PROC INTEGER(KIND=JPIM) :: IPTRGP(KFIELDS) INTEGER(KIND=JPIM) :: J REAL(KIND=JPHOOK) :: ZHOOK_HANDLE !-------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('CPL_INT_MOD:CPL_INT',0,ZHOOK_HANDLE) IF(PRESENT(KPTRGP)) THEN IPTRGP(:)=KPTRGP(1:KFIELDS) ELSE DO J=1,KFIELDS IPTRGP(J)=J ENDDO ENDIF CALL CPL_PROC(PGTF,KENDROWL,KFIELDS,KFFIELDS,KLEN,KSTA,IPTRGP) IF (LHOOK) CALL DR_HOOK('CPL_INT_MOD:CPL_INT',1,ZHOOK_HANDLE) END SUBROUTINE CPL_INT END MODULE CPL_INT_MOD ectrans-1.8.0/src/etrans/cpu/internal/suestaonl_mod.F900000664000175000017500000003300615174631767023210 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE SUESTAONL_MOD CONTAINS SUBROUTINE SUESTAONL(KMEDIAP,KRESTM,LDWEIGHTED_DISTR,PWEIGHT,PMEDIAP,KPROCAGP) !**** *SUESTAONL * - Routine to initialize parallel environment, TAL ! Purpose. ! -------- ! Initialize D%NSTA and D%NONL. ! Calculation of distribution of grid points to processors : ! Splitting of grid in B direction !** Interface. ! ---------- ! *CALL* *SUESTAONL * ! Explicit arguments : ! -------------------- ! KMEDIAP - mean number of grid points per PE ! KRESTM - number of PEs with one extra point ! LDWEIGHTED_DISTR -true if weighted distribution ! PWEIGHT -weight per grid-point if weighted ! distribution ! PMEDIAP -mean weight per PE if weighted ! distribution ! KPROCAGP -number of grid points per A set ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. NONE. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option. ! - removal of LRPOLE in YOMCT0. ! - removal of code under LRPOLE. ! Modified 98-12-04 C. Fischer: merge with SUESTAONL (Aladin) ! 03-03-03 G. Radnoti: no merge: only difference with ! sustaonl: ezone added to last a-set ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! O.Spaniel Oct-2004 phasing for AL29 ! A.Bogatchev Sep-2010 phasing for AL37 ! R. El Khatib 09-Aug-2013 Allow LEQ_REGIONS ! R. El Khatib 26-Apr-2018 vectorization ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_ALLGATHERV, MPL_RECV, MPL_SEND USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, MTAGPART, NPRCIDS, MYPROC, NPROC USE TPMALD_DIM ,ONLY : RALD USE SET2PE_MOD ,ONLY : SET2PE USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & & N_REGIONS, N_REGIONS_NS, N_REGIONS_EW USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(IN) :: KRESTM REAL(KIND=JPRD),INTENT(IN) :: PWEIGHT(:) LOGICAL,INTENT(IN) :: LDWEIGHTED_DISTR REAL(KIND=JPRD),INTENT(IN) :: PMEDIAP INTEGER(KIND=JPIM),INTENT(IN) :: KPROCAGP(:) INTEGER(KIND=JPIM) :: IXPTLAT(R%NDGL), ILSTPTLAT(R%NDGL) INTEGER(KIND=JPIM) :: ICHK(R%NDLON,R%NDGL), ICOMBUF(R%NDGL*N_REGIONS_EW*2) INTEGER(KIND=JPIM) :: I1, I2, IBUFLEN, IDGLG, IDWIDE, & & IGL, IGL1, IGL2, IGLOFF, IGPTA, & & IGPTPRSETS, IGPTS, IGPTSP, ILEN, ILRECV, & & ILSEND, INPLAT, INXLAT, IPOS, & & IPROCB, IPTSRE, IRECV, & & IREST, ISEND, ITAG, JA, JB, JGL, JL, JNPTSRE, & & ILAT, ILON, ILOEN INTEGER(KIND=JPIM),ALLOCATABLE :: ICOMBUFG(:) REAL(KIND=JPRB),ALLOCATABLE :: ZWEIGHT(:,:) INTEGER(KIND=JPIM) :: JJ, ILENG(NPROC), IOFF(NPROC) LOGICAL :: LLABORT LOGICAL :: LLP1,LLP2 REAL(KIND=JPRB) :: ZLAT, ZLAT1(R%NDGL), ZCOMP REAL(KIND=JPRB) :: ZDIVID(R%NDGL),ZXPTLAT(R%NDGL) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ----------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('SUESTAONL_MOD:SUESTAONL',0,ZHOOK_HANDLE) IXPTLAT (:)=999999 ILSTPTLAT(:)=999999 LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IDWIDE = R%NDGL/2 IBUFLEN = R%NDGL*N_REGIONS_EW*2 IDGLG = R%NDGL I1 = MAX( 1,D%NFRSTLAT(MY_REGION_NS)-D%NFRSTLOFF) I2 = MIN(IDGLG,D%NLSTLAT (MY_REGION_NS)-D%NFRSTLOFF) ILEN = D%NLSTLAT(MY_REGION_NS) - D%NFRSTLAT(MY_REGION_NS)+1 IGPTPRSETS = SUM(G%NLOEN(1:D%NFRSTLAT(MY_REGION_NS)-1)) IF (D%LSPLIT) THEN IF( LEQ_REGIONS )THEN IGPTA=0 DO JA=1,MY_REGION_NS-1 IGPTA = IGPTA + KPROCAGP(JA) ENDDO IGPTS = KPROCAGP(MY_REGION_NS) ELSE IF (MY_REGION_NS <= KRESTM.OR.KRESTM == 0) THEN IF (MY_REGION_NS < N_REGIONS_NS) THEN IGPTS = KMEDIAP IGPTA = KMEDIAP*(MY_REGION_NS-1) ELSE IGPTS = KMEDIAP+SUM(G%NLOEN(RALD%NDGUX+1:R%NDGL)) IGPTA = KMEDIAP*(MY_REGION_NS-1) ENDIF ELSE IF (MY_REGION_NS < N_REGIONS_NS) THEN IGPTS = KMEDIAP-1 IGPTA = KMEDIAP*KRESTM+IGPTS*(MY_REGION_NS-1-KRESTM) ELSE IGPTS = KMEDIAP-1+SUM(G%NLOEN(RALD%NDGUX+1:R%NDGL)) IGPTA = KMEDIAP*KRESTM+(KMEDIAP-1)*(MY_REGION_NS-1-KRESTM) ENDIF ENDIF ENDIF ELSE IGPTA = IGPTPRSETS IGPTS = SUM(G%NLOEN(D%NFRSTLAT(MY_REGION_NS):D%NLSTLAT(MY_REGION_NS))) ENDIF IGPTSP = IGPTS/N_REGIONS(MY_REGION_NS) IREST = IGPTS-N_REGIONS(MY_REGION_NS)*IGPTSP IXPTLAT(1) = IGPTA-IGPTPRSETS+1 ZXPTLAT(1) = REAL(IXPTLAT(1)) ILSTPTLAT(1) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)) INPLAT = G%NLOEN(D%NFRSTLAT(MY_REGION_NS))-IXPTLAT(1)+1 DO JGL=2,ILEN IXPTLAT(JGL) = 1 ZXPTLAT(JGL) = 1.0_JPRB ILSTPTLAT(JGL) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) INPLAT = INPLAT+G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) ENDDO ILSTPTLAT(ILEN) = G%NLOEN(D%NLSTLAT(MY_REGION_NS))-INPLAT+IGPTS DO JB=1,N_REGIONS_EW DO JGL=1,R%NDGL+N_REGIONS_NS-1 D%NSTA(JGL,JB) = 0 D%NONL(JGL,JB) = 0 ENDDO ENDDO ! grid point decomposition ! --------------------------------------- DO JGL=1,ILEN ZDIVID(JGL)=1._JPRB/REAL(G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1),JPRB) ENDDO IF( LDWEIGHTED_DISTR )THEN ALLOCATE(ZWEIGHT(G%NLOEN(R%NDGL/2),R%NDGL)) IGL=0 DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) IGL=IGL+1 ZWEIGHT(JL,JGL)=PWEIGHT(IGL) ENDDO ENDDO ZCOMP=0 IGPTS=0 ENDIF DO JB=1,N_REGIONS(MY_REGION_NS) IF( .NOT.LDWEIGHTED_DISTR )THEN IF (JB <= IREST) THEN IPTSRE = IGPTSP+1 ELSE IPTSRE = IGPTSP ENDIF DO JNPTSRE=1,IPTSRE ZLAT = 1._JPRB DO JGL=1,ILEN ZLAT1(JGL) = (ZXPTLAT(JGL)-1.0_JPRB)*ZDIVID(JGL) ENDDO DO JGL=1,ILEN IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN IF (ZLAT1(JGL) < ZLAT) THEN ZLAT=ZLAT1(JGL) INXLAT = JGL ENDIF ENDIF ENDDO IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN IGL=D%NPTRFLOFF+INXLAT IF (D%NSTA(IGL,JB) == 0) THEN D%NSTA(IGL,JB) = IXPTLAT(INXLAT) ENDIF D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 ENDIF IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 ZXPTLAT(INXLAT) = REAL(IXPTLAT(INXLAT),JPRB) ENDDO ELSE DO WHILE ( (JB < N_REGIONS(MY_REGION_NS) .AND. ZCOMP < PMEDIAP) & & .OR. (JB == N_REGIONS(MY_REGION_NS) .AND. IGPTS < KPROCAGP(MY_REGION_NS)) ) IGPTS = IGPTS + 1 ZLAT = 1._JPRB DO JGL=1,ILEN ZLAT1(JGL) = (ZXPTLAT(JGL)-1.0_JPRB)*ZDIVID(JGL) ENDDO DO JGL=1,ILEN IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN IF (ZLAT1(JGL) < ZLAT) THEN ZLAT = ZLAT1(JGL) INXLAT = JGL ENDIF ENDIF ENDDO IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN IGL=D%NPTRFLOFF+INXLAT IF (D%NSTA(IGL,JB) == 0) THEN D%NSTA(IGL,JB) = IXPTLAT(INXLAT) ENDIF D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 IF(IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1)THEN CALL ABORT_TRANS(' SUSTAONL: IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1') ENDIF ILON=D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 ILAT=D%NFRSTLAT(MY_REGION_NS)+INXLAT-1 ILOEN=G%NLOEN(ILAT) IF(ILON<1.OR.ILON>ILOEN)THEN CALL ABORT_TRANS(' SUSTAONL: ILON<1.OR.ILON>ILOEN') ENDIF ZCOMP = ZCOMP + ZWEIGHT(ILON,ILAT) ENDIF IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 ZXPTLAT(INXLAT) = REAL(IXPTLAT(INXLAT),JPRB) ENDDO ZCOMP = ZCOMP - PMEDIAP ENDIF ENDDO IF( LDWEIGHTED_DISTR )THEN DEALLOCATE(ZWEIGHT) ENDIF ! Exchange local partitioning info to produce global view IF( NPROC > 1 )THEN IF( LEQ_REGIONS )THEN ITAG = MTAGPART IPOS = 0 DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 IPOS = IPOS+1 ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,MY_REGION_EW) IPOS = IPOS+1 ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,MY_REGION_EW) ENDDO IF( IPOS > IBUFLEN )THEN CALL ABORT_TRANS(' SUSTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') ENDIF ILSEND = IPOS DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(IRECV,JA,JB,0,0) ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 ILENG(NPRCIDS(IRECV))=ILEN ENDDO ENDDO IOFF(1)=0 DO JJ=2,NPROC IOFF(JJ)=IOFF(JJ-1)+ILENG(JJ-1) ENDDO ALLOCATE(ICOMBUFG(SUM(ILENG(:)))) CALL MPL_ALLGATHERV(ICOMBUF(1:ILSEND),ICOMBUFG,ILENG,CDSTRING='SUSTAONL') DO JA=1,N_REGIONS_NS IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JB=1,N_REGIONS(JA) CALL SET2PE(IRECV,JA,JB,0,0) IF(IRECV /= MYPROC) THEN ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 IPOS = IOFF(NPRCIDS(IRECV)) DO JGL=IGL1,IGL2 IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 IPOS = IPOS+1 D%NSTA(IGL,JB) = ICOMBUFG(IPOS) IPOS = IPOS+1 D%NONL(IGL,JB) = ICOMBUFG(IPOS) ENDDO ENDIF ENDDO ENDDO DEALLOCATE(ICOMBUFG) ELSE ITAG = MTAGPART IPOS = 0 DO JB=1,N_REGIONS(MY_REGION_NS) DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 IPOS = IPOS+1 ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,JB) IPOS = IPOS+1 ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,JB) ENDDO ENDDO IF( IPOS > IBUFLEN )THEN CALL ABORT_TRANS(' SUESTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') ENDIF ILSEND = IPOS DO JA=1,N_REGIONS_NS CALL SET2PE(ISEND,JA,MY_REGION_EW,0,0) IF(ISEND /= MYPROC) THEN CALL MPL_SEND(ICOMBUF(1:ILSEND),KDEST=NPRCIDS(ISEND),KTAG=ITAG, & & CDSTRING='SUESTAONL:') ENDIF ENDDO DO JA=1,N_REGIONS_NS CALL SET2PE(IRECV,JA,MY_REGION_EW,0,0) IF(IRECV /= MYPROC) THEN ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*N_REGIONS(JA)*2 CALL MPL_RECV(ICOMBUF(1:ILEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, & & KOUNT=ILRECV,CDSTRING='SUESTAONL:') IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IPOS = 0 DO JB=1,N_REGIONS(JA) DO JGL=IGL1,IGL2 IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 IPOS = IPOS+1 D%NSTA(IGL,JB) = ICOMBUF(IPOS) IPOS = IPOS+1 D%NONL(IGL,JB) = ICOMBUF(IPOS) ENDDO ENDDO ENDIF ENDDO ENDIF ENDIF ! Confirm consistency of global partitioning, specifically testing for ! multiple assignments of same grid point and unassigned grid points LLABORT = .FALSE. DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) ICHK(JL,JGL) = 1 ENDDO ENDDO DO JA=1,N_REGIONS_NS IGLOFF = D%NPTRFRSTLAT(JA) DO JB=1,N_REGIONS(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JGL=IGL1,IGL2 IGL = IGLOFF+JGL-IGL1 DO JL=D%NSTA(IGL,JB),D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 IF( ICHK(JL,JGL) /= 1 )THEN WRITE(NOUT,'(" SUESTAONL : seta=",i4," setb=",i4,& & " row=",I4," sta=",I4," INVALID GRID POINT")')& & JA,JB,JGL,JL WRITE(0,'(" SUESTAONL : seta=",i4," setb=",i4,& & " ROW=",I4," sta=",I4," INVALID GRID POINT")')& & JA,JB,JGL,JL LLABORT = .TRUE. ENDIF ICHK(JL,JGL) = 2 ENDDO ENDDO ENDDO ENDDO DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) IF( ICHK(JL,JGL) /= 2 )THEN WRITE(NOUT,'(" SUESTAONL : row=",i4," sta=",i4,& & " GRID POINT NOT ASSIGNED")') JGL,JL LLABORT = .TRUE. ENDIF ENDDO ENDDO IF( LLABORT )THEN WRITE(NOUT,'(" SUESTAONL : inconsistent partitioning")') CALL ABORT_TRANS(' SUESTAONL: inconsistent partitioning') ENDIF IF (LLP1) THEN WRITE(UNIT=NOUT,FMT='('' OUTPUT FROM ROUTINE SUESTAONL '')') WRITE(UNIT=NOUT,FMT='('' '')') WRITE(UNIT=NOUT,FMT='('' PARTITIONING INFORMATION '')') WRITE(UNIT=NOUT,FMT='('' '')') IPROCB = MIN(32,N_REGIONS_EW) WRITE(UNIT=NOUT,FMT='(17X," SETB=",32(1X,I3))') (JB,JB=1,IPROCB) DO JA=1,N_REGIONS_NS IPROCB = MIN(32,N_REGIONS(JA)) WRITE(UNIT=NOUT,FMT='('' '')') IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JGL=IGL1,IGL2 IGL=IGLOFF+JGL-IGL1 WRITE(UNIT=NOUT,FMT='(" SETA=",I3," LAT=",I3," NSTA=",& & 32(1X,I3))') JA,JGL,(D%NSTA(IGL,JB),JB=1,IPROCB) WRITE(UNIT=NOUT,FMT='(" SETA=",I3," LAT=",I3," D%NONL=",& & 32(1X,I3))') JA,JGL,(D%NONL(IGL,JB),JB=1,IPROCB) WRITE(UNIT=NOUT,FMT='('' '')') ENDDO WRITE(UNIT=NOUT,FMT='('' '')') ENDDO WRITE(UNIT=NOUT,FMT='('' '')') WRITE(UNIT=NOUT,FMT='('' '')') ENDIF IF (LHOOK) CALL DR_HOOK('SUESTAONL_MOD:SUESTAONL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE SUESTAONL END MODULE SUESTAONL_MOD ectrans-1.8.0/src/etrans/cpu/internal/evdtuvad_mod.F900000664000175000017500000001136015174631767023014 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EVDTUVAD_MOD CONTAINS SUBROUTINE EVDTUVAD(KM,KMLOC,KFIELD,KFLDPTR,PVOR,PDIV,PU,PV,PSPMEANU,PSPMEANV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !USE TPM_DIM !USE TPM_FIELDS USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC USE TPMALD_FIELDS ,ONLY : FALD USE TPMALD_GEO ,ONLY : GALD USE TPMALD_DISTR ,ONLY : DALD !**** *EVDTUVAD* - Compute U,V in spectral space ! Purpose. ! -------- ! In Laplace space compute the the winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL EVDTUVAD(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! KFLDPTR - fields pointers ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PVOR(NLEI1,2*KFIELD) - vorticity (input) ! PDIV(NLEI1,2*KFIELD) - divergence (input) ! PU(NLEI1,2*KFIELD) - u wind (output) ! PV(NLEI1,2*KFIELD) - v wind (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUVAD in IFS CY22R1 ! 01-08-27 : R. El Khatib Fix for NPROMATR /= 0 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! 01-Dec-2004 A. Deckmyn Fix mean wind for NPRTRW > 1 ! N. Lopes & R. El Khatib 15-Jun-2012 Scalability enhancement + ! thread-safety ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM, KFIELD, KMLOC REAL(KIND=JPRB), INTENT(INOUT) :: PVOR(:,:),PDIV(:,:) REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:),PV (:,:) INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: KFLDPTR(:) REAL(KIND=JPRB), OPTIONAL, INTENT(OUT) :: PSPMEANU(:),PSPMEANV(:) INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, IFLD INTEGER(KIND=JPIM) :: IN INTEGER(KIND=JPIM) :: ISND, JA, ITAG, ILEN REAL(KIND=JPRB) :: ZSPU(2*KFIELD) REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZIN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EVDTUVAD_MOD:EVDTUVAD',0,ZHOOK_HANDLE) IF (KM == 0) THEN IF (PRESENT(KFLDPTR)) THEN DO J = 1, KFIELD IR = 2*J-1 IFLD=KFLDPTR(J) PSPMEANU(IFLD)=PU(1,IR) PSPMEANV(IFLD)=PV(1,IR) ENDDO ELSE DO J = 1, KFIELD IR = 2*J-1 PSPMEANU(J)=PU(1,IR) PSPMEANV(J)=PV(1,IR) ENDDO ENDIF ENDIF ZKM=REAL(KM,JPRB)*GALD%EXWN DO J=1,KFIELD IR = 2*J-1 II = IR+1 DO JN=1,DALD%NCPL2M(KM) IJ=(JN-1)/2 PDIV(JN,II)=PDIV(JN,II)-ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,IR) PU(JN,IR)=-FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,IR) PDIV(JN,IR)=PDIV(JN,IR)+ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,II) PU(JN,II)=-FALD%RLEPINM(DALD%NPME(KM)+IJ)*PU(JN,II) PVOR(JN,II)=PVOR(JN,II)-ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,IR) PV(JN,IR)=FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,IR) PVOR(JN,IR)=PVOR(JN,IR)+ZKM*FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,II) PV(JN,II)=FALD%RLEPINM(DALD%NPME(KM)+IJ)*PV(JN,II) ENDDO ENDDO DO J=1,2*KFIELD DO JN=1,DALD%NCPL2M(KM),2 IN = (JN-1)/2 ZIN = REAL(IN,JPRB)*GALD%EYWN PVOR(JN+1,J) = PVOR(JN+1,J)-ZIN*PU(JN ,J) PVOR(JN ,J) = PVOR(JN ,J)+ZIN*PU(JN+1,J) PDIV(JN+1,J) = PDIV(JN+1,J)-ZIN*PV(JN ,J) PDIV(JN ,J) = PDIV(JN ,J)+ZIN*PV(JN+1,J) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EVDTUVAD_MOD:EVDTUVAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EVDTUVAD END MODULE EVDTUVAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/suefft_mod.F900000664000175000017500000000520615174631767022470 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE SUEFFT_MOD CONTAINS SUBROUTINE SUEFFT USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G #ifdef WITH_FFT992 USE TPM_FFT ,ONLY : T USE TPMALD_FFT ,ONLY : TALD #endif USE TPM_FFTW ,ONLY : TW, INIT_PLANS_FFTW ! ! IMPLICIT NONE INTEGER(KIND=JPIM) :: JGL,IGLG, ILATS LOGICAL :: LLP1,LLP2 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SUEFFT_MOD:SUEFFT',0,ZHOOK_HANDLE) IF(.NOT.D%LGRIDONLY) THEN LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUEFFT ===' #ifdef WITH_FFT992 IF( TALD%LFFT992 )THEN NULLIFY(TW%FFTW_PLANS) ALLOCATE(T%TRIGS(R%NDLON+R%NNOEXTZL,D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'T%TRIGS ',SIZE(T%TRIGS),SHAPE(T%TRIGS) ALLOCATE(T%NFAX(19,D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'T%NFAX ',SIZE(T%NFAX),SHAPE(T%NFAX) ALLOCATE(T%LUSEFFT992(D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'T%LUSEFFT992',SIZE(T%LUSEFFT992),SHAPE(T%LUSEFFT992) ! ! create TRIGS and NFAX for latitude lengths supported by FFT992, ! that is just with factors 2, 3 or 5 ! ILATS=0 DO JGL=1,D%NDGL_FS IGLG = D%NPTRLS(MYSETW)+JGL-1 IF (G%NLOEN(IGLG)>1) THEN CALL SET99B(T%TRIGS(1,JGL),T%NFAX(1,JGL),G%NLOEN(IGLG)+R%NNOEXTZL,T%LUSEFFT992(JGL)) IF( .NOT.T%LUSEFFT992(JGL) )THEN ILATS=ILATS+1 ENDIF ENDIF ENDDO ALLOCATE(TALD%TRIGSE(R%NDGL+R%NNOEXTZG)) IF(LLP2)WRITE(NOUT,9) 'TALD%TRIGSE ',SIZE(TALD%TRIGSE),SHAPE(TALD%TRIGSE) ALLOCATE(TALD%NFAXE(19)) IF(LLP2)WRITE(NOUT,9) 'TALD%NFAXE ',SIZE(TALD%NFAXE),SHAPE(TALD%NFAXE) CALL SET99(TALD%TRIGSE,TALD%NFAXE,R%NDGL+R%NNOEXTZG) ELSE #endif CALL INIT_PLANS_FFTW(MAX(R%NDLON+R%NNOEXTZL,R%NDGL+R%NNOEXTZG)) #ifdef WITH_FFT992 ENDIF #endif ENDIF IF (LHOOK) CALL DR_HOOK('SUEFFT_MOD:SUEFFT',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUEFFT END MODULE SUEFFT_MOD ectrans-1.8.0/src/etrans/cpu/internal/eltdir_ctlad_mod.F900000664000175000017500000000713515174631767023631 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ELTDIR_CTLAD_MOD CONTAINS SUBROUTINE ELTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & & PSPVOR,PSPDIV,PSPSCALAR, & & PSPSC3A,PSPSC3B,PSPSC2, & & KFLDPTRUV,KFLDPTRSC,PSPMEANU,PSPMEANV) !**** *ELTDIR_CTLAD* - Control routine for direct Legendre transform ! Purpose. ! -------- ! Direct Legendre transform !** Interface. ! ---------- ! CALL LTDIR_CTLAD(...) ! Explicit arguments : ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : LALLOPERM !USE TPM_DIM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE ELTDIRAD_MOD ,ONLY : ELTDIRAD USE TRMTOL_MOD ,ONLY : TRMTOL IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPMEANV(:) INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Transposition from Fourier space distribution to spectral space distribution IF (LHOOK) CALL DR_HOOK('ELTDIR_CTLAD_MOD:ELTDIR_CTLAD',0,ZHOOK_HANDLE) IBLEN = D%NLENGT0B*2*KF_FS IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! force allocation here ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(1)=0._JPRB ! force allocation here ENDIF IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) FOUBUF(1)=0._JPRB ! force allocation here ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) FOUBUF(1)=0._JPRB ! force allocation here ENDIF ! Direct Legendre transform ILED2 = 2*KF_FS CALL GSTATS(1646,0) IF(KF_FS > 0) THEN !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL ELTDIRAD(IM,JM,KF_FS,KF_UV,KF_SCALARS,ILED2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC, PSPMEANU,PSPMEANV) ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1646,1) CALL GSTATS(181,0) CALL TRMTOL(FOUBUF,FOUBUF_IN,2*KF_FS) CALL GSTATS(181,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) IF (LHOOK) CALL DR_HOOK('ELTDIR_CTLAD_MOD:ELTDIR_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE ELTDIR_CTLAD END MODULE ELTDIR_CTLAD_MOD ectrans-1.8.0/src/etrans/cpu/internal/einv_trans_ctl_mod.F900000664000175000017500000002500415174631767024204 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EINV_TRANS_CTL_MOD CONTAINS SUBROUTINE EINV_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& & KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PSPMEANU,PSPMEANV) !**** *EINV_TRANS_CTL* - Control routine for inverse spectral transform. ! Purpose. ! -------- ! Control routine for the inverse spectral transform !** Interface. ! ---------- ! CALL EINV_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! 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. ! FSPGL_PROC - external procedure to be executed in fourier space ! before transposition ! PGP(:,:,:) - gridpoint fields (output) ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! vorticity : KF_UV_G fields ! divergence : KF_UV_G fields ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! N-S derivative of scalar fields : KF_SCALARS_G fields ! E-W derivative of u : KF_UV_G fields ! E-W derivative of v : KF_UV_G fields ! E-W derivative of scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN ,ONLY : NPROMATR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP !USE TPM_DISTR USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE ELTINV_CTL_MOD ,ONLY : ELTINV_CTL USE EFTINV_CTL_MOD ,ONLY : EFTINV_CTL ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) 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(:) REAL(KIND=JPRB) ,OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPMEANV(:) ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Perform transform IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTL_MOD:EINV_TRANS_CTL',0,ZHOOK_HANDLE) IF_GPB = 2*KF_UV_G+KF_SCALARS_G IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC, & & KVSETUV,KVSETSC) IBLKS=(IF_GPB-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF(LSCDERS) THEN IF_SCDERS = IF_SCALARS ELSE IF_SCDERS = 0 ENDIF IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS IF(LVORGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF(LDIVGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF_FS = IF_OUT_LT+IF_SCDERS IF(LUVDER) THEN IF_FS = IF_FS+2*IF_UV ENDIF IF_GP = 2*IF_UV_G+IF_SCALARS_G IOFFD = 0 IOFFU = 0 IOFFV = KF_UV_G IOFFUVD = 2*KF_UV_G+KF_SCALARS_G IOFFSC = 2*KF_UV_G IF(LVORGP) THEN IF_GP = IF_GP+IF_UV_G IOFFD = KF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LDIVGP) THEN IF_GP = IF_GP+IF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LSCDERS) THEN IF_GP = IF_GP+2*IF_SCALARS_G IOFFUVD =IOFFUVD+KF_SCALARS_G IOFFSCNS = IOFFSC+KF_SCALARS_G IOFFSCEW = IOFFSC+2*KF_SCALARS_G ENDIF IF(LUVDER) THEN IF_GP = IF_GP+2*IF_UV_G IOFFSCEW = IOFFSCEW+2*KF_UV_G ENDIF DO JFLD=1,IF_UV_G IOFF = 0 IF(LVORGP) THEN IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IF(LDIVGP) THEN IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G+IF_SCALARS_G IF(LSCDERS) THEN IOFF = IOFF+IF_SCALARS_G ENDIF IF(LUVDER) THEN IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_SCALARS_G IOFF = 2*IF_UV_G IF (LVORGP) IOFF = IOFF+IF_UV_G IF (LDIVGP) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LSCDERS) THEN IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LUVDER) THEN IOFF = IOFF+2*IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO CALL ELTINV_CTL(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,& & PSPMEANU=PSPMEANU,PSPMEANV=PSPMEANV,FSPGL_PROC=FSPGL_PROC) IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL EFTINV_CTL(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL EFTINV_CTL(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL EFTINV_CTL(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ENDIF ENDDO ELSE ! No splitting of fields, transform done in one go CALL ELTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& & PSPMEANU=PSPMEANU,PSPMEANV=PSPMEANV,FSPGL_PROC=FSPGL_PROC) CALL EFTINV_CTL(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) ENDIF IF (LHOOK) CALL DR_HOOK('EINV_TRANS_CTL_MOD:EINV_TRANS_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EINV_TRANS_CTL END MODULE EINV_TRANS_CTL_MOD ectrans-1.8.0/src/etrans/cpu/internal/easre1b_mod.F900000664000175000017500000000625015174631767022516 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EASRE1B_MOD CONTAINS SUBROUTINE EASRE1B(KFC,KM,KMLOC,PIA) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_TRANS ,ONLY : FOUBUF_IN USE TPM_DISTR ,ONLY : D !**** *ASRE1B* - Recombine antisymmetric and symmetric parts ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *ASRE1B(..) ! Explicit arguments : ! ------------------- KFC - number of fields (input-c) ! KM - zonal wavenumber(input-c) ! KMLOC - local version of KM (input-c) ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM (input) ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM (input) ! Implicit arguments : FOUBUF_IN - output buffer (output) ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1B in IFS CY22R1 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! R. El Khatib 26-Aug-2021 Optimizations ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC REAL(KIND=JPRB), INTENT(IN) :: PIA(RALD%NDGLSUR+R%NNOEXTZG,KFC) INTEGER(KIND=JPIM) :: JFLD, JGL ,IPROC INTEGER(KIND=JPIM) :: IISTAN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. ! --------------------------------------------------- IF (LHOOK) CALL DR_HOOK('EASRE1B_MOD:EASRE1B',0,ZHOOK_HANDLE) #ifdef __INTEL_COMPILER !$OMP SIMD PRIVATE(JGL) DO JFLD=1,KFC DO JGL=1,R%NDGL FOUBUF_IN((D%NSTAGT0B(D%NPROCL(JGL))+D%NPNTGTB1(KMLOC,JGL))*KFC+JFLD)=PIA(JGL,JFLD) ENDDO ENDDO #else DO JGL=1,R%NDGL IPROC=D%NPROCL(JGL) IISTAN=(D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*KFC DO JFLD =1,KFC FOUBUF_IN(IISTAN+JFLD)=PIA(JGL,JFLD) ENDDO ENDDO #endif IF (LHOOK) CALL DR_HOOK('EASRE1B_MOD:EASRE1B',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE EASRE1B END MODULE EASRE1B_MOD ectrans-1.8.0/src/etrans/cpu/external/0000775000175000017500000000000015174631767020060 5ustar alastairalastairectrans-1.8.0/src/etrans/cpu/external/etrans_end.F900000664000175000017500000001030015174631767022454 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 ETRANS_END(CDMODE) !**** *ETRANS_END* - Terminate transform package ! Purpose. ! -------- ! Terminate transform package. Release all allocated arrays. !** Interface. ! ---------- ! CALL ETRANS_END ! Explicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing cy37 after G.Radnoti ! R. El Khatib 02-Mar-2012 Support for mixed multi-resolutions ! R. El Khatib 09-Jul-2013 LENABLED ! R. El Khatib 01-Set-2015 Support for FFTW ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : MSETUP0, NCUR_RESOL, NDEF_RESOL, NMAX_RESOL, LENABLED USE TPM_DIM ,ONLY : R, DIM_RESOL USE TPM_DISTR ,ONLY : D, DISTR_RESOL, NPRCIDS USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL #ifdef WITH_FFT992 USE TPM_FFT ,ONLY : T, FFT_RESOL USE TPMALD_FFT ,ONLY : TALD, ALDFFT_RESOL #endif USE TPM_FFTW ,ONLY : TW, FFTW_RESOL USE TPM_FLT ,ONLY : S, FLT_RESOL USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL USE TPMALD_DISTR ,ONLY : DALD, ALDDISTR_RESOL USE TPMALD_FIELDS ,ONLY : FALD, ALDFIELDS_RESOL USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EQ_REGIONS_MOD ,ONLY : N_REGIONS USE EDEALLOC_RESOL_MOD ,ONLY : EDEALLOC_RESOL IMPLICIT NONE CHARACTER(LEN=5), OPTIONAL, INTENT(IN) :: CDMODE ! Local variables CHARACTER(LEN=5) :: CLMODE INTEGER(KIND=JPIM) :: JRES REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ETRANS_END',0,ZHOOK_HANDLE) CLMODE='FINAL' IF (PRESENT(CDMODE)) CLMODE=CDMODE IF (CLMODE == 'FINAL') THEN DO JRES=1,NDEF_RESOL CALL EDEALLOC_RESOL(JRES) ENDDO NULLIFY(R) IF (ALLOCATED(DIM_RESOL)) DEALLOCATE(DIM_RESOL) NULLIFY(RALD) IF (ALLOCATED(ALDDIM_RESOL)) DEALLOCATE(ALDDIM_RESOL) !EQ_REGIONS IF (ASSOCIATED(N_REGIONS)) THEN DEALLOCATE(N_REGIONS) NULLIFY (N_REGIONS) ENDIF !TPM_DISTR NULLIFY(D) IF (ALLOCATED(DISTR_RESOL)) DEALLOCATE(DISTR_RESOL) NULLIFY(DALD) IF (ALLOCATED(ALDDISTR_RESOL)) DEALLOCATE(ALDDISTR_RESOL) #ifdef WITH_FFT992 !TPM_FFT NULLIFY(T) IF (ALLOCATED(FFT_RESOL)) DEALLOCATE(FFT_RESOL) #endif !TPM_FFTW NULLIFY(TW) DEALLOCATE(FFTW_RESOL) !TPM_FLT NULLIFY(S) IF (ALLOCATED(FLT_RESOL)) DEALLOCATE(FLT_RESOL) #ifdef WITH_FFT992 NULLIFY(TALD) IF (ALLOCATED(ALDFFT_RESOL)) DEALLOCATE(ALDFFT_RESOL) #endif !TPM_FIELDS NULLIFY(F) IF (ALLOCATED(FIELDS_RESOL)) DEALLOCATE(FIELDS_RESOL) NULLIFY(FALD) IF (ALLOCATED(ALDFIELDS_RESOL)) DEALLOCATE(ALDFIELDS_RESOL) !TPM_GEOMETRY NULLIFY(G) IF(ALLOCATED(GEOM_RESOL)) DEALLOCATE(GEOM_RESOL) NULLIFY(GALD) IF(ALLOCATED(ALDGEO_RESOL)) DEALLOCATE(ALDGEO_RESOL) !TPM_TRANS IF(ALLOCATED(FOUBUF_IN)) DEALLOCATE(FOUBUF_IN) IF(ALLOCATED(FOUBUF)) DEALLOCATE(FOUBUF) IF (ALLOCATED(LENABLED)) DEALLOCATE(LENABLED) MSETUP0 = 0 NMAX_RESOL = 0 NCUR_RESOL = 0 NDEF_RESOL = 0 ENDIF IF (CLMODE == 'FINAL' .OR. CLMODE == 'INTER') THEN !EQ_REGIONS IF (ASSOCIATED(N_REGIONS)) THEN DEALLOCATE(N_REGIONS) NULLIFY (N_REGIONS) ENDIF !TPM_DISTR IF (ALLOCATED(NPRCIDS)) DEALLOCATE(NPRCIDS) ENDIF IF (LHOOK) CALL DR_HOOK('ETRANS_END',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE ETRANS_END ectrans-1.8.0/src/etrans/cpu/external/egath_grid.F900000664000175000017500000000766415174631767022452 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EGATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *EGATH_GRID* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL EGATH_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:,:) - Local spectral array ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT !USE TPM_DIM USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE GATH_GRID_CTL_MOD ,ONLY : GATH_GRID_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM),INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFRECV,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EGATH_GRID',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_GRID: KTO TOO SHORT!') ENDIF IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_GRID:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_GRID:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'GATH_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFGATHG) THEN WRITE(NOUT,*)'GATH_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFGATHG CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'GATH_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('GATH_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('GATH_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFRECV) THEN CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL GATH_GRID_CTL(PGPG,KFGATHG,IPROMA,KTO,PGP) IF (LHOOK) CALL DR_HOOK('EGATH_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EGATH_GRID ectrans-1.8.0/src/etrans/cpu/external/esetup_trans.F900000664000175000017500000002236415174631767023063 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 ESETUP_TRANS(KMSMAX,KSMAX,KDGL,KDGUX,KLOEN,LDSPLIT,& & KTMAX,KRESOL,PEXWN,PEYWN,PWEIGHT,LDGRIDONLY,KNOEXTZL,KNOEXTZG, & & LDUSEFFTW,LD_ALL_FFTW) !**** *ESETUP_TRANS* - Setup transform package for specific resolution ! Purpose. ! -------- ! To setup for making spectral transforms. Each call to this routine ! creates a new resolution up to a maximum of NMAX_RESOL set up in ! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can ! be called. !** Interface. ! ---------- ! CALL ESETUP_TRANS(...) ! Explicit arguments : KLOEN,LDSPLIT are optional arguments ! -------------------- ! KSMAX - spectral truncation required ! KDGL - number of Gaussian latitudes ! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] ! LDSPLIT - true if split latitudes in grid-point space [false] ! KTMAX - truncation order for tendencies? ! KRESOL - the resolution identifier ! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution ! in spectral and grid-point space ! LDGRIDONLY - true if only grid space is required ! LDSPLIT describe the distribution among processors of ! grid-point data and has no relevance if you are using a single processor ! LDUSEFFTW - Use FFTW for FFTs ! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ESETUP_DIMS - setup distribution independent dimensions ! SUEMP_TRANS_PRELEG - first part of setup of distr. environment ! SULEG - Compute Legandre polonomial and Gaussian ! Latitudes and Weights ! ESETUP_GEOM - Compute arrays related to grid-point geometry ! SUEMP_TRANS - Second part of setup of distributed environment ! SUEFFT - setup for FFT ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 02-04-11 A. Bogatchev: Passing of TCDIS ! 02-11-14 C. Fischer: soften test on KDGL ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing cy37 ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! R. El Khatib 02-Mar-2012 Support for mixed multi-resolutions ! R. El Khatib 09-Aug-2012 %LAM in GEOM_TYPE ! R. El Khatib 14-Jun-2013 LENABLED ! R. El Khatib 01-Sep-2015 Support for FFTW ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, NPRINTLEV, MSETUP0, & & NCUR_RESOL, NDEF_RESOL, NMAX_RESOL, LENABLED USE TPM_DIM ,ONLY : R, DIM_RESOL USE TPM_DISTR ,ONLY : D, DISTR_RESOL USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : FIELDS_RESOL #ifdef WITH_FFT992 USE TPM_FFT ,ONLY : T, FFT_RESOL USE TPMALD_FFT ,ONLY : TALD, ALDFFT_RESOL #endif USE TPM_FFTW ,ONLY : TW, FFTW_RESOL USE TPM_FLT ,ONLY : FLT_RESOL USE TPM_CTL ,ONLY : CTL_RESOL USE TPMALD_DIM ,ONLY : RALD, ALDDIM_RESOL USE TPMALD_DISTR ,ONLY : ALDDISTR_RESOL USE TPMALD_FIELDS ,ONLY : ALDFIELDS_RESOL USE TPMALD_GEO ,ONLY : GALD, ALDGEO_RESOL USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE ESETUP_DIMS_MOD ,ONLY : ESETUP_DIMS USE SUEMP_TRANS_MOD ,ONLY : SUEMP_TRANS USE SUEMP_TRANS_PRELEG_MOD ,ONLY : SUEMP_TRANS_PRELEG !USE SULEG_MOD USE ESETUP_GEOM_MOD ,ONLY : ESETUP_GEOM USE SUEFFT_MOD ,ONLY : SUEFFT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KMSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(:) LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT LOGICAL ,OPTIONAL,INTENT(IN) :: LDGRIDONLY INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KTMAX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEXWN REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEYWN REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZG LOGICAL ,OPTIONAL,INTENT(IN) :: LDUSEFFTW LOGICAL ,OPTIONAL,INTENT(IN) :: LD_ALL_FFTW !ifndef INTERFACE ! Local variables LOGICAL :: LLP1,LLP2 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('ESETUP_TRANS',0,ZHOOK_HANDLE) IF(MSETUP0 == 0) THEN CALL ABORT_TRANS('ESETUP_TRANS: SETUP_TRANS0 HAS TO BE CALLED BEFORE ESETUP_TRANS') ENDIF LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE ESETUP_TRANS ===' ! Allocate resolution dependent structures common to global and LAM IF(.NOT. ALLOCATED(DIM_RESOL)) THEN NDEF_RESOL = 1 ALLOCATE(DIM_RESOL(NMAX_RESOL)) ALLOCATE(FIELDS_RESOL(NMAX_RESOL)) ALLOCATE(GEOM_RESOL(NMAX_RESOL)) ALLOCATE(DISTR_RESOL(NMAX_RESOL)) #ifdef WITH_FFT992 ALLOCATE(FFT_RESOL(NMAX_RESOL)) #endif ALLOCATE(FFTW_RESOL(NMAX_RESOL)) ALLOCATE(FLT_RESOL(NMAX_RESOL)) ALLOCATE(CTL_RESOL(NMAX_RESOL)) GEOM_RESOL(:)%LAM=.FALSE. ALLOCATE(LENABLED(NMAX_RESOL)) LENABLED(:)=.FALSE. ELSE NDEF_RESOL = NDEF_RESOL+1 IF(NDEF_RESOL > NMAX_RESOL) THEN CALL ABORT_TRANS('ESETUP_TRANS:NDEF_RESOL > NMAX_RESOL') ENDIF ENDIF ! Allocate LAM-specific resolution dependent structures IF(.NOT. ALLOCATED(ALDDIM_RESOL)) THEN ALLOCATE(ALDDIM_RESOL(NMAX_RESOL)) ALLOCATE(ALDFIELDS_RESOL(NMAX_RESOL)) ALLOCATE(ALDGEO_RESOL(NMAX_RESOL)) ALLOCATE(ALDDISTR_RESOL(NMAX_RESOL)) #ifdef WITH_FFT992 ALLOCATE(ALDFFT_RESOL(NMAX_RESOL)) #endif ENDIF IF (PRESENT(KRESOL)) THEN KRESOL=NDEF_RESOL ENDIF ! Point at structures due to be initialized CALL ESET_RESOL(NDEF_RESOL) IF(LLP1) WRITE(NOUT,*) '=== DEFINING RESOLUTION ',NCUR_RESOL ! Defaults for optional arguments G%LREDUCED_GRID = .FALSE. D%LGRIDONLY = .FALSE. D%LSPLIT = .FALSE. #ifdef WITH_FFT992 TALD%LFFT992=.TRUE. ! Use FFT992 interface for FFTs #endif TW%LALL_FFTW=.FALSE. ! transform fields one at a time ! NON-OPTIONAL ARGUMENTS R%NSMAX = KSMAX RALD%NMSMAX=KMSMAX RALD%NDGUX=KDGUX R%NDGL = KDGL RALD%NDGLSUR=KDGL+2 R%NDLON =KLOEN(1) ! IMPLICIT argument : G%LAM = .TRUE. IF (KDGL <= 0) THEN CALL ABORT_TRANS ('ESETUP_TRANS: KDGL IS NOT A POSITIVE NUMBER') ENDIF ! Optional arguments ALLOCATE(G%NLOEN(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'NLOEN ',SIZE(G%NLOEN ),SHAPE(G%NLOEN ) IF (G%LREDUCED_GRID) THEN G%NLOEN(:) = KLOEN(1:R%NDGL) ELSE G%NLOEN(:) = R%NDLON ENDIF IF(PRESENT(LDSPLIT)) THEN D%LSPLIT = LDSPLIT ENDIF IF(PRESENT(KTMAX)) THEN R%NTMAX = KTMAX ELSE R%NTMAX = R%NSMAX ENDIF IF(R%NTMAX /= R%NSMAX) THEN !This SHOULD work but I don't know how to test it /MH WRITE(NERR,*) 'R%NTMAX /= R%NSMAX',R%NTMAX,R%NSMAX CALL ABORT_TRANS('ESETUP_TRANS:R%NTMAX /= R%NSMAX HAS NOT BEEN VALIDATED') ENDIF IF(PRESENT(PWEIGHT)) THEN D%LWEIGHTED_DISTR = .TRUE. IF( D%LWEIGHTED_DISTR .AND. .NOT.D%LSPLIT )THEN CALL ABORT_TRANS('SETUP_TRANS: LWEIGHTED_DISTR=T AND LSPLIT=F NOT SUPPORTED') ENDIF IF(SIZE(PWEIGHT) /= SUM(G%NLOEN(:)) )THEN CALL ABORT_TRANS('SETUP_TRANS:SIZE(PWEIGHT) /= SUM(G%NLOEN(:))') ENDIF ALLOCATE(D%RWEIGHT(SIZE(PWEIGHT))) D%RWEIGHT(:)=PWEIGHT(:) ELSE D%LWEIGHTED_DISTR = .FALSE. ENDIF IF(PRESENT(LDGRIDONLY)) THEN D%LGRIDONLY=LDGRIDONLY ENDIF IF (PRESENT(KNOEXTZL)) THEN R%NNOEXTZL=KNOEXTZL ELSE R%NNOEXTZL=0 ENDIF IF (PRESENT(KNOEXTZG)) THEN R%NNOEXTZG=KNOEXTZG ELSE R%NNOEXTZG=0 ENDIF IF(PRESENT(LD_ALL_FFTW)) THEN TW%LALL_FFTW=LD_ALL_FFTW ENDIF #ifdef WITH_FFT992 IF(PRESENT(LDUSEFFTW)) THEN TALD%LFFT992=.NOT.LDUSEFFTW ELSE TALD%LFFT992=.TRUE. ENDIF #endif ! Setup resolution dependent structures ! ------------------------------------- ! Setup distribution independent dimensions CALL ESETUP_DIMS IF (PRESENT(PEXWN)) GALD%EXWN=PEXWN IF (PRESENT(PEYWN)) GALD%EYWN=PEYWN ! First part of setup of distributed environment CALL SUEMP_TRANS_PRELEG CALL GSTATS(1802,0) ! Compute arrays related to grid-point geometry CALL ESETUP_GEOM ! Second part of setup of distributed environment CALL SUEMP_TRANS ! Initialize Fast Fourier Transform package CALL SUEFFT CALL GSTATS(1802,1) ! Signal the current resolution is active LENABLED(NDEF_RESOL)=.TRUE. IF (LHOOK) CALL DR_HOOK('ESETUP_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) !endif INTERFACE END SUBROUTINE ESETUP_TRANS ectrans-1.8.0/src/etrans/cpu/external/einv_transad.F900000664000175000017500000005431315174631767023023 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EINV_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,PMEANU,PMEANV) !**** *EINV_TRANSAD* - Inverse spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform - adjoint !** Interface. ! ---------- ! CALL EINV_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 resolution (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. ESET_RESOL - set resolution ! ---------- ELTDIR_CTLAD - control of Legendre transform ! EFTDIR_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti: like in direct code: IF_SCALARS_G fields (if pspscalar ! present and LDSCDERS) ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, NPROMATR !USE TPM_DIM USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV !USE TPM_GEOMETRY !USE TPM_FIELDS !USE TPM_FFT USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EINV_TRANS_CTLAD_MOD ,ONLY : EINV_TRANS_CTLAD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) 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(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANV(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC !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('EINV_TRANSAD',0,ZHOOK_HANDLE) CALL GSTATS(1809,0) ! Set current resolution CALL ESET_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,*) 'EINV_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('EINV_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,*) 'EINV_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('EINV_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('EINV_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,*) 'EINV_TRANSAD:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('EINV_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('EINV_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,*) 'EINV_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('EINV_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,*) 'EINV_TRANSAD:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('EINV_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("EINV_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING") ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'EINV_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& & UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS("EINV_TRANSAD : PSPVOR TOO SHORT") ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS("EINV_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("EINV_TRANSAD : PSPDIV TOO SHORT") ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('EINV_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'EINV_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('EINV_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('EINV_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('EINV_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('EINV_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('EINV_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('EINV_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IF(PRESENT(PGPUV)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGPUV CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3A)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP3A CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3B)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP3B CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP2)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'EINV_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('EINV_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('EINV_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('EINV_TRANSAD:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('EINV_TRANSAD:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'EINV_TRANSAD:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'EINV_TRANSAD:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < IF_UV_PAR) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('EINV_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,*)'EINV_TRANSAD:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('EINV_TRANSAD:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('EINV_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,*)'EINV_TRANSAD:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'EINV_TRANSAD:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('EINV_TRANSAD:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('EINV_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,*)'EINV_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('EINV_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'EINV_TRANSAD:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 CALL ABORT_TRANS('EINV_TRANSAD:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN WRITE(NOUT,*)'EINV_TRANSAD:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('EINV_TRANSAD:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'EINV_TRANSAD:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('EINV_TRANSAD:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('EINV_TRANSAD:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1809,1) ! ------------------------------------------------------------------ ! Perform transform CALL EINV_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,& & PMEANU,PMEANV) IF (LHOOK) CALL DR_HOOK('EINV_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EINV_TRANSAD ectrans-1.8.0/src/etrans/cpu/external/einv_trans.F900000664000175000017500000005417315174631767022522 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EINV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & FSPGL_PROC,& & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) !**** *EINV_TRANS* - Inverse spectral transform. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform !** Interface. ! ---------- ! CALL EINV_TRANS(...) ! Explicit arguments : All arguments 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 resolution (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 ! ---------- LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields ! and derivatives (IF_SCALARS_G) ! Y. Seity and G. Radnoti : 03-09-29 : phasing for AL27 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, NPROMATR !USE TPM_DIM USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV !USE TPM_GEOMETRY !USE TPM_FIELDS !USE TPM_FFT USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EINV_TRANS_CTL_MOD ,ONLY : EINV_TRANS_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: 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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMEANV(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC !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('EINV_TRANS',0,ZHOOK_HANDLE) CALL GSTATS(1807,0) ! Set current resolution CALL ESET_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_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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(.NOT. PRESENT(PSPSCALAR) ) THEN CALL ABORT_TRANS('INV_TRANS : KVSETSC PRESENT BUT PSPSCALAR MISSING') ENDIF IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN WRITE(NERR,*) 'INV_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_TRANS: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_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_TRANS: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_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS& & ('INV_TRANS: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_TRANS: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_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_G > 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_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('INV_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('INV_TRANS : 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IF(PRESENT(PGPUV)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGPUV CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3A)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3A CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3B)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3B CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP2)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'INV_TRANS: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_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS: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_TRANS:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('INV_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < IF_UV_PAR) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1807,1) ! ------------------------------------------------------------------ ! Perform transform CALL EINV_TRANS_CTL(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,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV ) IF (LHOOK) CALL DR_HOOK('EINV_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EINV_TRANS ectrans-1.8.0/src/etrans/cpu/external/edir_trans.F900000664000175000017500000004556215174631767022506 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EDIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV,AUX_PROC) !**** *EDIR_TRANS* - Direct spectral transform (from grid-point to spectral). ! Purpose. ! -------- ! Interface routine for the direct spectral transform !** Interface. ! ---------- ! CALL EDIR_TRANS(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 resolution (input) ! PGP(:,:,:) - gridpoint fields (input) ! 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): ! 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) ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! PMEANU(:),PMEANV(:) - mean wind ! AUX_PROC - optional external procedure for biperiodization of ! aux.fields ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ELTDIR_CTL - control of Legendre transform ! EFTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti: 01-03-13 adaptation to aladin ! P. Smolikova 02-09-30 : AUX_PROC for d4 in NH ! Y. Seity and G. Radnoti : 03-09-29 : phasing for AL27 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Bogatchev 19-04-2013 Comparison of ubound(pspdiv,1) ! with ubound(pspvor,1) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EDIR_TRANS_CTL_MOD ,ONLY : EDIR_TRANS_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !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(:,:) 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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) 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(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PMEANV(:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EDIR_TRANS',0,ZHOOK_HANDLE) CALL GSTATS(1808,0) CALL ESET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT ! This is for use in TRGTOL which is shared with adjoint inverse transform LSCDERS=.FALSE. LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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 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,*) 'DIR_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANS : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= UBOUND(PSPVOR,1)) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_TRANS: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,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1808,1) ! ------------------------------------------------------------------ CALL EDIR_TRANS_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV,AUX_PROC) IF (LHOOK) CALL DR_HOOK('EDIR_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EDIR_TRANS ectrans-1.8.0/src/etrans/cpu/external/etrans_release.F900000664000175000017500000000257615174631767023346 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 ETRANS_RELEASE(KRESOL) !**** *ETRANS_RELEASE* - release a spectral resolution ! Purpose. ! -------- ! Release all arrays related to a given resolution tag !** Interface. ! ---------- ! CALL ETRANS_RELEASE ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM !ifndef INTERFACE USE EDEALLOC_RESOL_MOD ,ONLY : EDEALLOC_RESOL ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL !endif INTERFACE ! ------------------------------------------------------------------ CALL EDEALLOC_RESOL(KRESOL) ! ------------------------------------------------------------------ END SUBROUTINE ETRANS_RELEASE ectrans-1.8.0/src/etrans/cpu/external/etrans_inq.F900000664000175000017500000004362115174631767022511 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 ETRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& & KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& & KMYMS,KESM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& & KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& & KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& & KULTPP,KPTRLS,& & KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& & LDSPLITLAT,LDLINEAR_GRID,& & KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,KDEF_RESOL,LDLAM,& & PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KCPL2M,KCPL4M ,KPROCM) !**** *ETRANS_INQ* - Extract information from the transform package ! Purpose. ! -------- ! Interface routine for extracting information from the T.P. !** Interface. ! ---------- ! CALL ETRANS_INQ(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resolution (input) ! MULTI-TRANSFORMS MANAGEMENT ! KDEF_RESOL - number or resolutions defined ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! SPECTRAL SPACE ! KSPEC - number of complex spectral coefficients on this PE ! KSPEC2 - 2*KSPEC ! KSPEC2G - global KSPEC2 ! KSPEC2MX - maximun KSPEC2 among all PEs ! KNUMP - Number of spectral waves handled by this PE ! KGPTOT - Total number of grid columns on this PE ! KGPTOTG - Total number of grid columns on the Globe ! KGPTOTMX - Maximum number of grid columns on any of the PEs ! KGPTOTL - Number of grid columns one each PE (dimension ! N_REGIONS_NS:N_REGIONS_EW) ! KMYMS - This PEs spectral zonal wavenumbers ! KESM0 - Address in a spectral array of (m, n=m) ! KUMPP - No. of wave numbers each wave set is responsible for ! KPOSSP - Defines partitioning of global spectral fields among PEs ! KPTRMS - Pointer to the first wave number of a given a-set ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KSMAX - spectral truncation - n direction ! KMSMAX - spectral truncation - m direction ! KNVALUE - n value for each KSPEC2 spectral coeffient ! KMVALUE - m value for each KSPEC2 spectral coeffient ! LDLINEAR_GRID : .TRUE. if the grid is linear ! GRIDPOINT SPACE ! KFRSTLAT - First latitude of each a-set in grid-point space ! KLSTTLAT - Last latitude of each a-set in grid-point space ! KFRSTLOFF - Offset for first lat of own a-set in grid-point space ! KPTRLAT - Pointer to the start of each latitude ! KPTRFRSTLAT - Pointer to the first latitude of each a-set in ! NSTA and NONL arrays ! KPTRLSTLAT - Pointer to the last latitude of each a-set in ! NSTA and NONL arrays ! KPTRFLOFF - Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 ! KSTA - Position of first grid column for the latitudes on a ! processor. The information is available for all processors. ! The b-sets are distinguished by the last dimension of ! nsta().The latitude band for each a-set is addressed by ! nptrfrstlat(jaset),nptrlstlat(jaset), and ! nptrfloff=nptrfrstlat(myseta) on this processors a-set. ! Each split latitude has two entries in nsta(,:) which ! necessitates the rather complex addressing of nsta(,:) ! and the overdimensioning of nsta by N_REGIONS_NS. ! KONL - Number of grid columns for the latitudes on a processor. ! Similar to nsta() in data structure. ! LDSPLITLAT - TRUE if latitude is split in grid point space over ! two a-sets ! FOURIER SPACE ! KULTPP - number of latitudes for which each a-set is calculating ! the FFT's. ! KPTRLS - pointer to first global latitude of each a-set for which ! it performs the Fourier calculations ! LEGENDRE ! PMU - sin(Gaussian latitudes) ! PGW - Gaussian weights ! PRPNM - Legendre polynomials ! KLEI3 - First dimension of Legendre polynomials ! KSPOLEGL - Second dimension of Legendre polynomials ! KPMS - Adress for legendre polynomial for given M (NSMAX) ! PLEPINM - Eigen-values of the inverse Laplace operator ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing with TFL 36R4 ! R. El Khatib 08-Aug-2012 KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,LDLAM,KDEF_RESOL,LDLINEAR_GRID ! T. Dalkilic 28-Aug-2012 KCPL4M ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NDEF_RESOL USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRNS, NPRTRW, MYSETV, MYSETW USE TPMALD_DIM ,ONLY : RALD USE TPMALD_DISTR ,ONLY : DALD USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F USE TPMALD_FIELDS USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & & N_REGIONS_EW, N_REGIONS_NS USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2 INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2G INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2MX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KNUMP INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOT INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTG INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTMX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTL(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KMYMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KESM0(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KUMPP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPOSSP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KALLMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KDIM0G(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLOFF INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFLOFF INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSTA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KONL(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KULTPP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW LOGICAL ,OPTIONAL,INTENT(INOUT) :: LDSPLITLAT(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMU(:) REAL(KIND=JPRB) ,OPTIONAL :: PGW(:) ! Argument NOT used REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PRPNM(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLEI3 INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPOLEGL INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPMS(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL2M(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL4M(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPROCM(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMVALUE(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PLEPINM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLINEAR_GRID !ifndef INTERFACE INTEGER(KIND=JPIM) :: IU1,IU2 INTEGER(KIND=JPIM) :: IC, JN, JMLOC, IM, JJ, JM INTEGER(KIND=JPIM) :: ISMAX(0:R%NSMAX),ISNAX(0:RALD%NMSMAX),ICPLM(0:RALD%NMSMAX) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('ETRANS_INQ',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) IF(PRESENT(KSPEC)) KSPEC = D%NSPEC IF(PRESENT(KSPEC2)) KSPEC2 = D%NSPEC2 IF(PRESENT(KSPEC2G)) KSPEC2G = R%NSPEC2_G IF(PRESENT(KSPEC2MX)) KSPEC2MX = D%NSPEC2MX IF(PRESENT(KNUMP)) KNUMP = D%NUMP IF(PRESENT(KGPTOT)) KGPTOT = D%NGPTOT IF(PRESENT(KGPTOTG)) KGPTOTG = D%NGPTOTG IF(PRESENT(KGPTOTMX)) KGPTOTMX = D%NGPTOTMX IF(PRESENT(KFRSTLOFF)) KFRSTLOFF = D%NFRSTLOFF IF(PRESENT(KPTRFLOFF)) KPTRFLOFF = D%NPTRFLOFF IF(PRESENT(KPRTRW)) KPRTRW = NPRTRW IF(PRESENT(KMYSETW)) KMYSETW = MYSETW IF(PRESENT(KMYSETV)) KMYSETV = MYSETV IF(PRESENT(KMY_REGION_NS)) KMY_REGION_NS = MY_REGION_NS IF(PRESENT(KMY_REGION_EW)) KMY_REGION_EW = MY_REGION_EW IF(PRESENT(LDLAM)) LDLAM = G%LAM IF(PRESENT(KDEF_RESOL)) KDEF_RESOL = NDEF_RESOL IF(PRESENT(KGPTOTL)) THEN IF(UBOUND(KGPTOTL,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KGPTOTL DIM 1 TOO SMALL') ELSEIF(UBOUND(KGPTOTL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('ETRANS_INQ: KGPTOTL DIM 2 TOO SMALL') ELSE KGPTOTL(1:N_REGIONS_NS,1:N_REGIONS_EW) = D%NGPTOTL(:,:) ENDIF ENDIF IF(PRESENT(KMYMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KMYMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KMYMS,1) < D%NUMP) THEN CALL ABORT_TRANS('ETRANS_INQ: KMYMS TOO SMALL') ELSE KMYMS(1:D%NUMP) = D%MYMS(:) ENDIF ENDIF IF(PRESENT(KESM0)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KESM0 REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KESM0,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KESM0 TOO SMALL') ELSE KESM0(0:RALD%NMSMAX) = DALD%NESM0(:) ENDIF ENDIF IF(PRESENT(KCPL2M)) THEN IF(UBOUND(KCPL2M,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KCPL2M TOO SMALL') ELSE KCPL2M(0:RALD%NMSMAX) = DALD%NCPL2M(:) ENDIF ENDIF IF(PRESENT(KPROCM)) THEN IF(UBOUND(KPROCM,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KPROCM TOO SMALL') ELSE KPROCM(0:RALD%NMSMAX) = D%NPROCM(:) ENDIF ENDIF IF(PRESENT(KUMPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KUMPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KUMPP,1) < NPRTRW) THEN CALL ABORT_TRANS('ETRANS_INQ: KUMPP TOO SMALL') ELSE KUMPP(1:NPRTRW) = D%NUMPP(:) ENDIF ENDIF IF(PRESENT(KPOSSP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPOSSP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPOSSP,1) < NPRTRW+1) THEN CALL ABORT_TRANS('ETRANS_INQ: KPOSSP TOO SMALL') ELSE KPOSSP(1:NPRTRW+1) = D%NPOSSP(:) ENDIF ENDIF IF(PRESENT(KPTRMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRMS,1) < NPRTRW) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRMS TOO SMALL') ELSE KPTRMS(1:NPRTRW) = D%NPTRMS(:) ENDIF ENDIF IF(PRESENT(KALLMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KALLMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KALLMS,1) < RALD%NMSMAX+1) THEN CALL ABORT_TRANS('ETRANS_INQ: KALLMS TOO SMALL') ELSE KALLMS(1:RALD%NMSMAX+1) = D%NALLMS(:) ENDIF ENDIF IF(PRESENT(KDIM0G)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KDIM0G REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KDIM0G,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KDIM0G TOO SMALL') ELSE KDIM0G(0:RALD%NMSMAX) = D%NDIM0G(0:RALD%NMSMAX) ENDIF ENDIF IF(PRESENT(KFRSTLAT)) THEN IF(UBOUND(KFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KFRSTLAT TOO SMALL') ELSE KFRSTLAT(1:N_REGIONS_NS) = D%NFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KLSTLAT)) THEN IF(UBOUND(KLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KLSTLAT TOO SMALL') ELSE KLSTLAT(1:N_REGIONS_NS) = D%NLSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLAT)) THEN IF(UBOUND(KPTRLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLAT TOO SMALL') ELSE KPTRLAT(1:R%NDGL) = D%NPTRLAT(:) ENDIF ENDIF IF(PRESENT(KPTRFRSTLAT)) THEN IF(UBOUND(KPTRFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRFRSTLAT TOO SMALL') ELSE KPTRFRSTLAT(1:N_REGIONS_NS) = D%NPTRFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLSTLAT)) THEN IF(UBOUND(KPTRLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLSTLAT TOO SMALL') ELSE KPTRLSTLAT(1:N_REGIONS_NS) = D%NPTRLSTLAT(:) ENDIF ENDIF IF(PRESENT(KSTA)) THEN IF(UBOUND(KSTA,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('ETRANS_INQ: KSTA DIM 1 TOO SMALL') ELSEIF(UBOUND(KSTA,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('ETRANS_INQ: KSTA DIM 2 TOO SMALL') ELSE KSTA(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NSTA(:,:) ENDIF ENDIF IF(PRESENT(KONL)) THEN IF(UBOUND(KONL,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('ETRANS_INQ: KONL DIM 1 TOO SMALL') ELSEIF(UBOUND(KONL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('ETRANS_INQ: KONL DIM 2 TOO SMALL') ELSE KONL(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NONL(:,:) ENDIF ENDIF IF(PRESENT(LDSPLITLAT)) THEN IF(UBOUND(LDSPLITLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('ETRANS_INQ: LDSPLITLAT TOO SMALL') ELSE LDSPLITLAT(1:R%NDGL) = D%LSPLITLAT(:) ENDIF ENDIF IF(PRESENT(KULTPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KULTPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KULTPP,1) < NPRTRNS) THEN CALL ABORT_TRANS('ETRANS_INQ: KULTPP TOO SMALL') ELSE KULTPP(1:NPRTRNS) = D%NULTPP(:) ENDIF ENDIF IF(PRESENT(KPTRLS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRLS,1) < NPRTRNS) THEN CALL ABORT_TRANS('ETRANS_INQ: KPTRLS TOO SMALL') ELSE KPTRLS(1:NPRTRNS) = D%NPTRLS(:) ENDIF ENDIF IF(PRESENT(PMU)) THEN IF(UBOUND(PMU,1) < R%NDGL) THEN CALL ABORT_TRANS('ETRANS_INQ: PMU TOO SMALL') ELSE PMU(1:R%NDGL) = F%RMU ENDIF ENDIF IF(PRESENT(PRPNM)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: PRPNM REQUIRED BUT LGRIDONLY=T') ENDIF IU1 = UBOUND(PRPNM,1) IU2 = UBOUND(PRPNM,2) IF(IU1 < R%NDGNH) THEN CALL ABORT_TRANS('ETRANS_INQ:FIRST DIM. OF PRNM TOO SMALL') ELSE IU1 = MIN(IU1,R%NLEI3) IU2 = MIN(IU2,D%NSPOLEGL) PRPNM(1:IU1,1:IU2) = F%RPNM(1:IU1,1:IU2) ENDIF ENDIF IF(PRESENT(KLEI3)) THEN KLEI3=R%NLEI3 ENDIF IF(PRESENT(KSPOLEGL)) THEN KSPOLEGL=D%NSPOLEGL ENDIF IF(PRESENT(KPMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KPMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPMS,1) < R%NSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KPMS TOO SMALL') ELSE KPMS(0:R%NSMAX) = D%NPMS(0:R%NSMAX) ENDIF ENDIF IF(PRESENT(KSMAX)) KSMAX = R%NSMAX IF(PRESENT(KMSMAX)) KMSMAX = RALD%NMSMAX IF(PRESENT(PLEPINM)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: PLEPINM REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(PLEPINM,1) < R%NSPEC_G/2) THEN CALL ABORT_TRANS('ETRANS_INQ: PLEPINM TOO SMALL') ELSEIF (LBOUND(PLEPINM,1) /= -1) THEN CALL ABORT_TRANS('ETRANS_INQ: LOWER BOUND OF PLEPINM SHOULD BE -1') ELSE PLEPINM(:) = FALD%RLEPINM(:) ENDIF ENDIF IF(PRESENT(KNVALUE)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') ENDIF IF(SIZE(KNVALUE) < D%NSPEC2) THEN CALL ABORT_TRANS('ETRANS_INQ: KNVALUE TOO SMALL') ELSE CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) DO JM=0,RALD%NMSMAX ICPLM(JM) = 1*(ISNAX(JM)+1) ENDDO IC=1 DO JMLOC=1,D%NUMP IM=D%MYMS(JMLOC) DO JN=0,ICPLM(IM)-1 DO JJ=0,3 KNVALUE(IC+JJ)=JN ENDDO IC=IC+4 ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KMVALUE)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') ENDIF IF(SIZE(KMVALUE) < D%NSPEC2) THEN CALL ABORT_TRANS('ETRANS_INQ: KMVALUE TOO SMALL') ELSE CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) DO JM=0,RALD%NMSMAX ICPLM(JM) = 1*(ISNAX(JM)+1) ENDDO IC=1 DO JMLOC=1,D%NUMP IM=D%MYMS(JMLOC) DO JN=0,ICPLM(IM)-1 DO JJ=0,3 KMVALUE(IC+JJ)=IM ENDDO IC=IC+4 ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KCPL4M)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('ETRANS_INQ: KCPL4M REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KCPL4M,1) < RALD%NMSMAX) THEN CALL ABORT_TRANS('ETRANS_INQ: KCPL4M TOO SMALL') ELSE CALL ELLIPS(R%NSMAX,RALD%NMSMAX,ISNAX,ISMAX) DO JM=0,RALD%NMSMAX KCPL4M(JM) = 4*(ISNAX(JM)+1) ENDDO ENDIF ENDIF IF(PRESENT(LDLINEAR_GRID)) THEN LDLINEAR_GRID = R%NSMAX > (R%NDGL -1)/3 .OR. RALD%NMSMAX > (R%NDLON -1)/3 ENDIF IF (LHOOK) CALL DR_HOOK('ETRANS_INQ',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE ETRANS_INQ ectrans-1.8.0/src/etrans/cpu/external/egpnorm_trans.F900000664000175000017500000000576615174631767023234 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EGPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !**** *EGPNORM_TRANS* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL EGPNORM_TRANS(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! Modifications. ! -------------- ! Original : 19th Sept 2008 ! R. El Khatib 07-08-2009 Optimisation directive for NEC ! R. El Khatib 16-Sep-2019 merge with global model code ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD !ifndef INTERFACE USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DIM ,ONLY : R USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE GPNORM_TRANS_CTL_MOD, ONLY : GPNORM_TRANS_CTL USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL ,INTENT(IN) :: LDAVE_ONLY INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE CHARACTER(LEN=80) :: CLENV REAL(KIND=JPRD) :: ZW(R%NDGL) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE IF (LHOOK) CALL DR_HOOK('EGPNORM_TRANS',0,ZHOOK_HANDLE) ! Set current resolution CALL ESET_RESOL(KRESOL) CALL GET_ENVIRONMENT_VARIABLE("EGPNORM_OLD",CLENV) IF (LEN_TRIM(CLENV) > 0) THEN ZW(:) = 1._JPRD/G%NLOEN ELSE ZW(:) = 1._JPRD/R%NDGL ENDIF CALL GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,ZW) IF (LHOOK) CALL DR_HOOK('EGPNORM_TRANS',1,ZHOOK_HANDLE) !endif INTERFACE END SUBROUTINE EGPNORM_TRANS ectrans-1.8.0/src/etrans/cpu/external/edir_transad.F900000664000175000017500000004436415174631767023012 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EDIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) !**** *EDIR_TRANSAD* - Direct spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the direct spectral transform - adjoint !** Interface. ! ---------- ! CALL EDIR_TRANSAD(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 resolution (input) ! PGP(:,:,:) - gridpoint fields (input) ! 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): ! 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) ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- EDIR_TRANS_CTLAD - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NF_SC2, NF_SC3A, NF_SC3B, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE EDIR_TRANS_CTLAD_MOD ,ONLY : EDIR_TRANS_CTLAD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) 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) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSETSC2(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANU(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMEANV(:) !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EDIR_TRANSAD',0,ZHOOK_HANDLE) CALL GSTATS(1810,0) ! Set current resolution CALL ESET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT LSCDERS=.FALSE. ! This is for use in TRLTOG which is shared with inverse transform LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANSAD:KVSETUV 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 ENDIF IF(PRESENT(KVSETSC)) THEN IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC 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('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& & UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= IF_UV) THEN WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& & UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANSAD : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_TRANS: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,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1810,1) ! Perform transform CALL EDIR_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2,& & PMEANU,PMEANV) IF (LHOOK) CALL DR_HOOK('EDIR_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE EDIR_TRANSAD ectrans-1.8.0/src/etrans/cpu/external/edist_spec.F900000664000175000017500000001356615174631767022475 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EDIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& & LDIM1_IS_FLD,KSORT) !**** *EDIST_SPEC* - Distribute global spectral array among processors ! Purpose. ! -------- ! Interface routine for distributing spectral array !** Interface. ! ---------- ! CALL EDIST__SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PSPEC(:,:) - Local spectral array ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- DIST_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! P.Marguinaud 10-Oct-2014 Add KSORT argument (change the order of fields) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC USE TPMALD_DISTR ,ONLY : DALD USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE DIST_SPEC_CONTROL_MOD ,ONLY : DIST_SPEC_CONTROL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM),INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL LOGICAL ,OPTIONAL,INTENT(IN) :: LDIM1_IS_FLD REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFDISTG) INTEGER(KIND=JPIM) :: IFSEND,IFRECV,J, IFLD, ICOEFF INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G, ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) LLDIM1_IS_FLD=.TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD=LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD=1 ICOEFF=2 ELSE IFLD=2 ICOEFF=1 ENDIF ISMAX = RALD%NMSMAX ALLOCATE(IDIM0G(0:ISMAX)) ALLOCATE(IALLMS(ISMAX+1)) ALLOCATE(IKN(0:ISMAX)) ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ISPEC2MX = D%NSPEC2MX IUMPP(:) = D%NUMPP(:) IALLMS(:) = D%NALLMS(:) IPTRMS(:) = D%NPTRMS(:) DO J=0,ISMAX IKN(J)=2*DALD%NCPL2M(J) ENDDO IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('EDIST_SPEC: KFROM TOO SHORT!') ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'EDIST_SPEC:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('EDIST_SPEC:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('EDIST_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFSEND) THEN WRITE(NERR,*)'EDIST_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFSEND CALL ABORT_TRANS('EDIST_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*)'EDIST_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('EDIST_SPEC: COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFDISTG) THEN CALL ABORT_TRANS('EDIST_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFDISTG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'EDIST_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('EDIST_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFRECV = IFRECV+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFDISTG) ELSE IFRECV = KFDISTG IVSET(:) = MYSETV ENDIF IF(IFRECV > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('EDIST_SPEC: FIELDS TO RECEIVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFRECV) THEN CALL ABORT_TRANS('EDIST_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('EDIST_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (.NOT. PRESENT (PSPEC)) THEN CALL ABORT_TRANS('EDIST_SPEC: KSORT REQUIRES PSPEC') ENDIF IF (UBOUND (KSORT, 1) /= UBOUND (PSPEC, IFLD)) THEN CALL ABORT_TRANS('EDIST_SPEC: DIMENSION MISMATCH KSORT, PSPEC') ENDIF ENDIF CALL DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,IVSET,PSPEC,LLDIM1_IS_FLD,& & ISMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,KSORT) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EDIST_SPEC ectrans-1.8.0/src/etrans/cpu/external/egath_spec.F900000664000175000017500000001453615174631767022453 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EGATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,KMSMAX,LDZA0IP) !**** *EGATH_SPEC* - Gather global spectral array from processors ! Purpose. ! -------- ! Interface routine for gathering spectral array !** Interface. ! ---------- ! CALL EGATH_SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for gathering each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PSPEC(:,:) - Local spectral array ! LDZA0IP - Set to zero imaginary part of first coefficients ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! Modified 03-09-30 Y. Seity, bug correction IFSEND=0 ! R. El Khatib 23-Oct-2012 Monkey business ! P.Marguinaud 10-Oct-2013 Add an option to set (or not) first ! coefficients imaginary part to zero ! R. El Khatib 01-Dec-2020 Merge egath_spec_control and gath_spec_control ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPMALD_DIM ,ONLY : RALD USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC USE TPMALD_DISTR USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE GATH_SPEC_CONTROL_MOD ,ONLY : GATH_SPEC_CONTROL 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) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMSMAX LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFGATHG) INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J INTEGER(KIND=JPIM) :: IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, IMSMAX, ISPEC2, ISPEC2_G,ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL ESET_RESOL(KRESOL) LLDIM1_IS_FLD = .TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD = 1 ICOEFF = 2 ELSE IFLD = 2 ICOEFF = 1 ENDIF IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('EGATH_SPEC: KTO TOO SHORT!') ENDIF ISMAX = R%NSMAX IMSMAX = RALD%NMSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX IF(PRESENT(KMSMAX)) IMSMAX = KMSMAX ALLOCATE(IDIM0G(0:IMSMAX)) ALLOCATE(IALLMS(IMSMAX+1)) ALLOCATE(IKN(0:IMSMAX)) IF(IMSMAX /= RALD%NMSMAX .OR. ISMAX /= R%NSMAX) THEN CALL ABORT_TRANS('EGATH_SPEC:TRUNCATION CHANGE NOT YET CODED') ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ISPEC2MX = D%NSPEC2MX IUMPP(:) = D%NUMPP(:) IALLMS(:) = D%NALLMS(:) IPTRMS(:) = D%NPTRMS(:) DO J=0,IMSMAX IKN(J)=2*DALD%NCPL2M(J) ENDDO ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'EGATH_SPEC:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('EGATH_SPEC:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('EGATH_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFRECV) THEN WRITE(NERR,*) 'EGATH_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFRECV CALL ABORT_TRANS('EGATH_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'EGATH_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('EGATH_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFGATHG) THEN CALL ABORT_TRANS('EGATH_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFGATHG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'EGATH_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('EGATH_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFSEND = IFSEND+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFGATHG) ELSEIF(NPRTRV > 1) THEN WRITE(NERR,*) 'EGATH_SPEC:KVSET MISSING, NPRTRV ',NPRTRV CALL ABORT_TRANS('EGATH_SPEC:KVSET MISSING, NPRTRV > 1') ELSE IFSEND = KFGATHG IVSET(:) = 1 ENDIF IF(IFSEND > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('EGATH_SPEC: FIELDS TO RECIEVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFSEND) THEN CALL ABORT_TRANS('EGATH_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('EGATH_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,& & IMSMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,LDZA0IP) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EGATH_SPEC ectrans-1.8.0/src/etrans/cpu/external/edist_grid.F900000664000175000017500000001043115174631767022454 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 EDIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) !**** *EDIST_GRID* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL EDIST_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:) - Local spectral array ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- DIST_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! P.Marguinaud 10-Oct-2014 Add KSORT argument ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT !USE TPM_DIM USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE DIST_GRID_CTL_MOD ,ONLY : DIST_GRID_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('EDIST_GRID',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('EDIST_GRID: KFROM TOO SHORT!') ENDIF IFSEND = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'EDIST_GRID:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('EDIST_GRID:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'EDIST_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFDISTG) THEN WRITE(NOUT,*)'EDIST_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFDISTG CALL ABORT_TRANS('EDIST_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'EDIST_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('EDIST_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('EDIST_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFSEND) THEN CALL ABORT_TRANS('EDIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (UBOUND (KSORT, 1) /= UBOUND (PGP, 2)) THEN CALL ABORT_TRANS('EDIST_GRID: DIMENSION MISMATCH KSORT, PGP') ENDIF ENDIF CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP,KSORT) IF (LHOOK) CALL DR_HOOK('EDIST_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE EDIST_GRID ectrans-1.8.0/src/etrans/cpu/external/especnorm.F900000664000175000017500000000764215174631767022344 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 ESPECNORM(PSPEC,KVSET,KMASTER,KRESOL,PMET,PNORM) !**** *ESPECNORM* - Compute global spectral norms ! Purpose. ! -------- ! Interface routine for computing spectral norms !** Interface. ! ---------- ! CALL ESPECNORM(...) ! Explicit arguments : All arguments optional ! -------------------- ! PSPEC(:,:) - Spectral array ! KVSET(:) - "B-Set" for each field ! KMASTER - processor to recieve norms ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PMET(:) - metric ! PNORM(:) - Norms (output for processor KMASTER) ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ESPNORM_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR !USE TPM_DIM USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV, MYPROC USE ESET_RESOL_MOD ,ONLY : ESET_RESOL USE ESPNORM_CTL_MOD ,ONLY : ESPNORM_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KMASTER INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PMET(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PNORM(:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IMASTER,IFLD,IFLD_G,J REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ ! Set current resolution IF (LHOOK) CALL DR_HOOK('ESPECNORM',0,ZHOOK_HANDLE) CALL ESET_RESOL(KRESOL) ! Set defaults IMASTER = 1 IFLD = 0 IF(PRESENT(KMASTER)) THEN IMASTER = KMASTER ENDIF IF(PRESENT(KVSET)) THEN IFLD_G = UBOUND(KVSET,1) DO J=1,IFLD_G IF(KVSET(J) > NPRTRV) THEN WRITE(NERR,*) 'ESPECNORM:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('ESPECNORM:KVSET TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFLD = IFLD+1 ENDIF ENDDO ELSE IF(PRESENT(PSPEC)) THEN IFLD = UBOUND(PSPEC,1) ENDIF IFLD_G = IFLD ENDIF IF(NPRTRV >1) THEN IF(IFLD > 0 .AND. .NOT. PRESENT(KVSET)) THEN WRITE(NERR,*)'NPRTRV >1 AND IFLD > 0 AND NOT PRESENT(KVSET)',& & NPRTRV,IFLD CALL ABORT_TRANS('ESPECNORM: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(MYPROC == IMASTER) THEN IF(.NOT. PRESENT(PNORM)) THEN CALL ABORT_TRANS('ESPECNORM: PNORM NOT PRESENT') ENDIF IF(UBOUND(PNORM,1) < IFLD_G) THEN CALL ABORT_TRANS('ESPECNORM: PNORM TOO SMALL') ENDIF ENDIF IF(IFLD > 0 ) THEN IF(.NOT. PRESENT(PSPEC)) THEN CALL ABORT_TRANS('ESPECNORM: PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,1) < IFLD) THEN CALL ABORT_TRANS('ESPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,2) < D%NSPEC2) THEN CALL ABORT_TRANS('ESPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL ESPNORM_CTL(PSPEC,IFLD,IFLD_G,KVSET,IMASTER,PMET,PNORM) IF (LHOOK) CALL DR_HOOK('ESPECNORM',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE ESPECNORM ectrans-1.8.0/src/etrans/cpu/CMakeLists.txt0000664000175000017500000001506215174631767021002 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. ## Apply workarounds for some known compilers ## see trans/ for example function(generate_backend_sources) set (options) set (oneValueArgs BACKEND DESTINATION OUTPUT) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(backend ${_PAR_BACKEND}) set(destination ${_PAR_DESTINATION}) file(MAKE_DIRECTORY ${destination}/biper/internal) file(MAKE_DIRECTORY ${destination}/biper/external) file(MAKE_DIRECTORY ${destination}/internal) file(MAKE_DIRECTORY ${destination}/external) ecbuild_list_add_pattern( LIST files GLOB internal/*.F90 external/*.F90 biper/internal/*.F90 biper/external/*.F90 QUIET ) set(outfiles) foreach(file_i ${files}) get_filename_component(outfile_name ${file_i} NAME) get_filename_component(outfile_name_we ${file_i} NAME_WE) get_filename_component(outfile_ext ${file_i} EXT) get_filename_component(outfile_dir ${file_i} DIRECTORY) set(outfile "${destination}/${file_i}") ecbuild_debug("Generate ${outfile}") generate_file(BACKEND ${backend} INPUT ${CMAKE_CURRENT_SOURCE_DIR}/${file_i} OUTPUT ${outfile}) list(APPEND outfiles ${outfile}) endforeach(file_i) set(${_PAR_OUTPUT} ${outfiles} PARENT_SCOPE) endfunction(generate_backend_sources) set( BUILD_INTERFACE_INCLUDE_DIR ${CMAKE_BINARY_DIR}/include/ectrans ) function(generate_etrans_dummy_sources) set (options) set (oneValueArgs BACKEND DESTINATION OUTPUT) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(backend ${_PAR_BACKEND}) set(destination ${_PAR_DESTINATION}) file(MAKE_DIRECTORY ${destination}/external) # Build list of interface files to generate dummy sources for ecbuild_list_add_pattern( LIST include_files GLOB etrans/*.h SOURCE_DIR ${PROJECT_SOURCE_DIR}/src/etrans/include QUIET ) foreach( include_file ${include_files} ) cmake_path( GET include_file STEM file_stem ) set(dummy_source "${file_stem}.F90") # First generate a dummy source file from the interface that just contains an abort file( READ ${include_file} contents ) string( REPLACE "END INTERFACE" "" contents "${contents}" ) string( REPLACE "INTERFACE" "" contents "${contents}" ) string( REPLACE "IMPLICIT NONE" "USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS\nIMPLICIT NONE" contents "${contents}" ) string( REPLACE "END SUBROUTINE" "CALL ABORT_TRANS(\"etrans dummy library - you should not be here\")\nEND SUBROUTINE" contents "${contents}" ) file( WRITE ${CMAKE_CURRENT_BINARY_DIR}/generated/etrans_dummy/${dummy_source} "${contents}" ) # Then run the dummy source through the normal backend file generator set(outfile "${destination}/${dummy_source}") ecbuild_debug("Generate ${outfile}") generate_file(BACKEND ${backend} INPUT ${CMAKE_CURRENT_BINARY_DIR}/generated/etrans_dummy/${dummy_source} OUTPUT ${outfile}) list(APPEND outfiles ${outfile}) endforeach( include_file ) set(${_PAR_OUTPUT} ${outfiles} PARENT_SCOPE) endfunction(generate_etrans_dummy_sources) foreach( prec dp sp ) if( HAVE_${prec} ) generate_backend_includes(BACKEND ${prec} TARGET ectrans_lam_${prec}_includes DESTINATION ${BUILD_INTERFACE_INCLUDE_DIR} INCLUDE_DIRECTORY ${PROJECT_SOURCE_DIR}/src/etrans/include ) if( NOT HAVE_ETRANS ) generate_etrans_dummy_sources( BACKEND ${prec} OUTPUT ectrans_lam_${prec}_src DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/generated/ectrans_lam_${prec} ) else() generate_backend_sources( BACKEND ${prec} OUTPUT ectrans_lam_${prec}_src DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/generated/ectrans_lam_${prec} ) endif() ecbuild_add_library( TARGET ectrans_lam_${prec} LINKER_LANGUAGE Fortran SOURCES ${ectrans_lam_${prec}_src} PUBLIC_INCLUDES $ $ $ PUBLIC_LIBS fiat ectrans_common ectrans_${prec}_includes ectrans_${prec} ectrans_lam_common ectrans_lam_${prec}_includes ) ecbuild_target_fortran_module_directory( TARGET ectrans_lam_${prec} MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/ectrans INSTALL_MODULE_DIRECTORY module/ectrans ) if( HAVE_ETRANS ) set( FFTW_LINK PRIVATE ) if( LAPACK_LIBRARIES MATCHES "mkl" AND NOT FFTW_LIBRARIES MATCHES "mkl" ) ecbuild_warn( "Danger: Both MKL and FFTW are linked in ectrans_lam_${prec}. " "No guarantees on link order can be made for the final executable.") set( FFTW_LINK PUBLIC ) # Attempt anyway to give FFTW precedence endif() ecbuild_debug("target_link_libraries( ectrans_lam_${prec} ${FFTW_LINK} ${FFTW_LIBRARIES} )") target_link_libraries( ectrans_lam_${prec} ${FFTW_LINK} ${FFTW_LIBRARIES} ) target_include_directories( ectrans_lam_${prec} PRIVATE ${FFTW_INCLUDE_DIRS} ) target_compile_definitions( ectrans_lam_${prec} PRIVATE WITH_FFTW ) # daand: lam transforms don't need lapack #ecbuild_debug("target_link_libraries( ectrans_lam_${prec} PRIVATE ${LAPACK_LIBRARIES} )") #target_link_libraries( ectrans_${prec} PRIVATE ${LAPACK_LIBRARIES} ) if( HAVE_OMP ) ecbuild_debug("target_link_libraries( ectrans_lam_${prec} PRIVATE OpenMP::OpenMP_Fortran )") target_link_libraries( ectrans_lam_${prec} PRIVATE OpenMP::OpenMP_Fortran ) endif() endif() # This interface library is for backward compatibility, and provides the older includes ecbuild_add_library( TARGET etrans_${prec} TYPE INTERFACE ) target_include_directories( etrans_${prec} INTERFACE $ ) target_include_directories( etrans_${prec} INTERFACE $ ) target_link_libraries( etrans_${prec} INTERFACE ectrans_lam_${prec} ) endif() endforeach() ## Install trans interface install( DIRECTORY ${BUILD_INTERFACE_INCLUDE_DIR}/ DESTINATION include/ectrans ) ectrans-1.8.0/src/etrans/cpu/biper/0000775000175000017500000000000015174631767017337 5ustar alastairalastairectrans-1.8.0/src/etrans/cpu/biper/internal/0000775000175000017500000000000015174631767021153 5ustar alastairalastairectrans-1.8.0/src/etrans/cpu/biper/internal/extper_mod.F900000664000175000017500000001130615174631767023602 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EXTPER_MOD CONTAINS SUBROUTINE EXTPER(PWORK,KDIM,KPSTA,KPOINTS,KFLDS,KUNITS,& & KPOINTERS,KALFA) ! purpose : ! -------- ! Make spline extension. ! *CALL* *EXTPER(PWORK,KDIM,KPSTA,KPOINTS,KFLDS,KUNITS,& ! & KPOINTERS,KALFA) ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! PWORK : Input: values in C U I area ! : Output: input+(spline extension on the E area) ! KDIM : Dimension of the C U I U E unit of work (one row or one m) ! KPSTA : Position where the unit of work starts ! KPOINTS : Position where the unit of work ends ! KFLDS : number of 2D fields ! KUNITS : Number of units of work ! KPOINTERS : Array of pointers for the units of work ! KALFA : boundary condition of a spline: ! = 0 ... natural spline ! = 1 ... boundary condition computed differentially ! (additional option) ! references : ! ---------- ! author : ! ------ ! M. Hortal 03-11-2009 ! ----------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_GEN USE TPM_DISTR IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDIM INTEGER(KIND=JPIM),INTENT(IN) :: KPSTA INTEGER(KIND=JPIM),INTENT(IN) :: KPOINTS INTEGER(KIND=JPIM),INTENT(IN) :: KFLDS INTEGER(KIND=JPIM),INTENT(IN) :: KUNITS INTEGER(KIND=JPIM),INTENT(IN) :: KPOINTERS(:) INTEGER(KIND=JPIM),INTENT(IN) :: KALFA ! arrays : ! -------- INTEGER(KIND=JPIM) :: IENDX, IENDY, JFL, JLAT, JLON, IA REAL(KIND=JPRB) :: ZA, ZB, ZC, ZD, ZEPSA, ZEPSB, ZJ, ZK, ZKP1,& & ZLAM, ZLAMB, ZM1, ZM2, ZMM, ZNY REAL(KIND=JPRB) :: ZMAX(KUNITS), ZMIN(KUNITS) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ #include "abor1.intfb.h" ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('EXTPER',0,ZHOOK_HANDLE) !* 0. Security ! -------- IF(UBOUND(PWORK,1) < KFLDS) THEN CALL ABOR1(' EXTPER, PWORK first dimension too small') ENDIF IF(UBOUND(PWORK,2) < KDIM+2) THEN WRITE(NOUT,*) ' UBOUND(PWORK,2)=',UBOUND(PWORK,2),' KDIM=',KDIM,' KUNITS=',& &KUNITS CALL ABOR1(' EXTPER, PWORK second dimension too small') ENDIF IF(UBOUND(KPOINTERS,1) < KUNITS) THEN CALL ABOR1(' EXTPER, KPOINTERS too small') ENDIF IF(UBOUND(PWORK,2) < KPOINTERS(KUNITS)+KDIM) THEN WRITE(NERR,*) ' EXTPER, KUNITS=',KUNITS,' KPOINTERS=',KPOINTERS(1:KUNITS),& &' KDIM=',KDIM,' UBOUND(PWORK,2)=',UBOUND(PWORK,2) CALL ABOR1(' EXTPER, value of KPOINTERS too large') ENDIF !* 1. Spline Extension. ! ------------------- DO JFL = 1, KFLDS ZK = REAL(KDIM-KPOINTS+1,JPRB) ZKP1 = ZK + 1.0_JPRB ZLAMB = ZK/ZKP1 ZNY = REAL(KALFA,JPRB)/ZKP1 DO JLAT=1,KUNITS ZEPSA = & &((PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK -& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS)+& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-1))*6._JPRB/ZKP1 -& & ZNY*(PWORK(JFL,KPOINTERS(JLAT)+KPOINTS)-& & 2.0_JPRB* PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-1)+& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS-2)) ZEPSB = (PWORK(JFL,KPOINTERS(JLAT)+KPSTA+1)-& & PWORK(JFL,KPOINTERS(JLAT)+KPSTA) -& & (PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK)*6._JPRB/ZKP1-& & ZNY*(PWORK(JFL,KPOINTERS(JLAT)+KPSTA+2)-& & 2.0_JPRB* PWORK(JFL,KPOINTERS(JLAT)+KPSTA+1)+& & PWORK(JFL,KPOINTERS(JLAT)+KPSTA)) ZMM = 4._JPRB - ZLAMB*ZLAMB ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ZMM ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ZMM ZA = PWORK(JFL,KPOINTERS(JLAT)+KPOINTS) ZB = (PWORK(JFL,KPOINTERS(JLAT)+KPSTA)-& & PWORK(JFL,KPOINTERS(JLAT)+KPOINTS))/ZK-& & (2.0_JPRB*ZM1 + ZM2) * ZK/6._JPRB ZC = 0.5_JPRB * ZM1 ZD = (ZM2 - ZM1)/(6._JPRB*ZK) DO JLON=KPOINTERS(JLAT)+KPOINTS+1,KPOINTERS(JLAT)+KDIM ZJ = REAL(JLON - (KPOINTERS(JLAT)+KPOINTS),JPRB) PWORK(JFL,JLON) = ZA + ZJ * (ZB + ZJ * (ZC + ZD * ZJ)) ENDDO ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('EXTPER',1,ZHOOK_HANDLE) END SUBROUTINE EXTPER END MODULE EXTPER_MOD ectrans-1.8.0/src/etrans/cpu/biper/internal/espline_mod.F900000664000175000017500000001457415174631767023744 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESPLINE_MOD CONTAINS SUBROUTINE ESPLINE(KDLUN,KDLON,KDGUN,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM,KDGSA,KDGEN,KNUBI,PWORK,PALFA,LDBIX,LDBIY,KDAD) ! purpose : ! -------- ! Make spline extension. ! *CALL* *ESPLINE*(...) ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! KDLUN : lower bound for the x (or longitude) dimension ! of the gridpoint array ! KDLON : upper bound for the x (or longitude) dimension ! of the gridpoint array on C U I U E ! KDGUN : lower bound for the y (or latitude) dimension ! of the gridpoint array ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U E ! KDLUX : upper bound for the x (or longitude) dimension ! of C U I. ! KDGUX : upper bound for the y (or latitude) dimension ! of C U I. ! KSTART : first dimension in x direction of g-p array ! KDLSM : last dimension in x direction of g-p array ! KDGSA : first dimension in y of g-p array ! KDGEN : last dimension in y of g-p array ! KNUBI : number of levels to biperiodicise ! PWORK : gridpoint array on C U I U E. ! PALFA : boundary condition of a spline: ! = 0. ... natural spline ! = 1. ... boundary condition computed differentially ! (additional option) ! LDBIX : .TRUE. biperiodicisation in x ( and vice versa ) ! LDBIY : .TRUE. biperiodicisation in y ( and vice versa ) ! KDAD : 1 for test of biperiodic. ! references : ! ---------- ! author : ! ------ ! Michal Batka and Radmila Bubnova ( B & B ) ! modifications : ! ------------- ! J.Vivoda 03-2002 2D model fix ! A. Stanesic : 28-03-08: KDADD - test of externalized biper. ! ------------------------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK ! ------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KSTART INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA INTEGER(KIND=JPIM),INTENT(IN) :: KDGEN INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KDLUN INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGUN INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(KSTART:KDLSM,KNUBI,KDGSA:KDGEN) REAL(KIND=JPRB) ,INTENT(IN) :: PALFA LOGICAL ,INTENT(IN) :: LDBIX LOGICAL ,INTENT(IN) :: LDBIY INTEGER(KIND=JPIM),INTENT(IN) :: KDAD ! ------------------------------------------------------------- LOGICAL :: LLBIX LOGICAL :: LLBIY INTEGER(KIND=JPIM) :: IENDX, IENDY, JFL, JLAT, JLON, IA REAL(KIND=JPRB) :: ZA, ZB, ZC, ZD, ZEPSA, ZEPSB, ZJ, ZK, ZKP1,& & ZLAM, ZLAMB, ZM1, ZM2, ZMM, ZNY REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESPLINE',0,ZHOOK_HANDLE) ! ------------------------------------------------------------- !* 1. Spline Extension. ! ------------------- LLBIX=LDBIX LLBIY=LDBIY IF( KDLUN==1.AND.KDLUX==1 ) LLBIX=.FALSE. IF( KDGUN==1.AND.KDGUX==1 ) LLBIY=.FALSE. IENDX = KDGUX IENDY = KDLON IF(LLBIX.AND.(.NOT.LLBIY)) THEN IENDY = KDLUN - 1 ELSEIF((.NOT.LLBIX).AND.LLBIY) THEN IENDX = KDGUN - 1 IENDY = KDLUX ELSEIF((.NOT.LLBIX).AND.(.NOT.LLBIY)) THEN IF (LHOOK) CALL DR_HOOK('ESPLINE',1,ZHOOK_HANDLE) RETURN ENDIF DO JFL = 1, KNUBI ZK = REAL(KDLON-KDLUX+1,JPRB) ZKP1 = ZK + 1.0_JPRB ZLAMB = ZK/ZKP1 ZNY = PALFA/ZKP1 DO JLAT=KDGUN,IENDX ZEPSA = ((PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK -& & PWORK(KDLUX,JFL,JLAT)+PWORK(KDLUX-1,JFL,JLAT))*6._JPRB/ZKP1 -& & ZNY*(PWORK(KDLUX,JFL,JLAT)-2.0_JPRB* PWORK(KDLUX-1,JFL,JLAT)+& & PWORK(KDLUX-2,JFL,JLAT)) ZEPSB = (PWORK(KDLUN+1,JFL,JLAT)-PWORK(KDLUN,JFL,JLAT) -& & (PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK)*6._JPRB/ZKP1-& & ZNY*(PWORK(KDLUN+2,JFL,JLAT)-2.0_JPRB* PWORK(KDLUN+1,JFL,JLAT)+& & PWORK(KDLUN,JFL,JLAT)) ZMM = 4._JPRB - ZLAMB*ZLAMB ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ZMM ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ZMM ZA = PWORK(KDLUX,JFL,JLAT) ZB = (PWORK(KDLUN,JFL,JLAT)-PWORK(KDLUX,JFL,JLAT))/ZK-& & (2.0_JPRB*ZM1 + ZM2) * ZK/6._JPRB ZC = 0.5_JPRB * ZM1 ZD = (ZM2 - ZM1)/(6._JPRB*ZK) DO JLON=KDLUX+1,KDLON+KDAD ZJ = REAL(JLON - KDLUX,JPRB) PWORK(JLON,JFL,JLAT) = ZA + ZJ * (ZB + ZJ * (ZC + ZD * ZJ)) ENDDO ENDDO ZK = REAL(KDGL - KDGUX + 1,JPRB) ZKP1 = ZK + 1 ZLAM = ZK/ZKP1 ZNY = PALFA/ZKP1 DO JLON=KDLUN,IENDY+KDAD ZEPSA = ((PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK -& & PWORK(JLON,JFL,KDGUX)+PWORK(JLON,JFL,KDGUX-1))*6._JPRB/ZKP1-& & ZNY*(PWORK(JLON,JFL,KDGUX)-2.0_JPRB*PWORK(JLON,JFL,KDGUX-1)+& & PWORK(JLON,JFL,KDGUX-2)) ZEPSB = (PWORK(JLON,JFL,KDGUN+1)-PWORK(JLON,JFL,KDGUN) -& & (PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK)*6._JPRB/ZKP1-& & ZNY*(PWORK(JLON,JFL,KDGUN+2)-2.0_JPRB*PWORK(JLON,JFL,KDGUN+1) +& & PWORK(JLON,JFL,KDGUN)) ZMM = 4._JPRB - ZLAMB*ZLAMB ZM1 = (2.0_JPRB*ZEPSA - ZLAMB*ZEPSB)/ ZMM ZM2 = (2.0_JPRB*ZEPSB - ZLAMB*ZEPSA)/ ZMM ZA = PWORK(JLON,JFL,KDGUX) ZB = (PWORK(JLON,JFL,KDGUN)-PWORK(JLON,JFL,KDGUX))/ZK - (2.0_JPRB*& & ZM1 & & + ZM2) * ZK/6._JPRB ZC = 0.5_JPRB * ZM1 ZD = (ZM2 - ZM1)/(6._JPRB*ZK) DO JLAT=KDGUX+1,KDGL+KDAD ZJ = REAL(JLAT - KDGUX,JPRB) PWORK(JLON,JFL,JLAT) = ZA +ZJ*(ZB +ZJ*(ZC + ZJ * ZD)) ENDDO ENDDO ENDDO ! ------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESPLINE',1,ZHOOK_HANDLE) END SUBROUTINE ESPLINE END MODULE ESPLINE_MOD ectrans-1.8.0/src/etrans/cpu/biper/internal/esmoothe_mod.F900000664000175000017500000001314215174631767024116 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ESMOOTHE_MOD CONTAINS SUBROUTINE ESMOOTHE(KDLUN,KDLON,KDGUN,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM,KDGSA,KDGEN,KNUBI,PWORK,LDBIX,LDBIY) ! purpose : ! -------- ! To smooth the fields over the extension zone. !* *CALL* *ESMOOTHE*(...) ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! KDLUN : lower bound for the x (or longitude) dimension ! of the gridpoint array ! KDLON : upper bound for the x (or longitude) dimension ! of the gridpoint array on C U I U E ! KDGUN : lower bound for the y (or latitude) dimension ! of the gridpoint array ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U E ! KDLUX : upper bound for the x (or longitude) dimension ! of C U I. ! KDGUX : upper bound for the y (or latitude) dimension ! of C U I. ! KDLSM : dimension in x direction of g-p array ! KDGSA : first dimension index in y of g-p array ! KDGEN : last dimension index in y of g-p array ! KSTART : first dimension index in x of g-p array ! KDLSM : last dimension index in x of g-p array ! KNUBI : number of levels to biperiodicise ! PWORK : gridpoint array on C U I U E. ! LDBIX : .TRUE.: biperiodicise in x direction (and vice versa) ! LDBIY : .TRUE.: biperiodicise in y direction (and vice versa) ! references : ! ---------- ! author : ! ------ ! Michal Batka and Radmila Bubnova ( B & B ) ! modifications : ! ------------- ! R. El Khatib 03-05-05 Optimizations ! -------------------------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK ! -------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KSTART INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA INTEGER(KIND=JPIM),INTENT(IN) :: KDGEN INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KDLUN INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGUN INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX REAL(KIND=JPRB) ,INTENT(INOUT) :: PWORK(KSTART:KDLSM,KNUBI,KDGSA:KDGEN) LOGICAL ,INTENT(IN) :: LDBIX LOGICAL ,INTENT(IN) :: LDBIY ! -------------------------------------------------------------- REAL(KIND=JPRB) :: ZPRAC(KDLUN-1:KDLON+1,KDGUN-1:KDGL+1) INTEGER(KIND=JPIM) :: IEND, IENX1, IENX2, IENY1, IENY2, JFL, JLAT, JLL, JLON REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! -------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESMOOTHE',0,ZHOOK_HANDLE) ! -------------------------------------------------------------- !* 1. Calculation. ! ------------ IEND = MAX(KDLON-KDLUX,KDGL-KDGUX) IEND = (IEND+1)/2 IENX1= KDLON IENX2= KDGL IENY1= KDGL IENY2= KDLON IF(LDBIX.AND.(.NOT.LDBIY)) THEN IENX2 = KDGUX IENY1 = KDGUX ELSEIF((.NOT.LDBIX).AND.LDBIY) THEN IENX1 = KDLUX IENY2 = KDLUX ELSEIF((.NOT.LDBIX).AND.(.NOT.LDBIY)) THEN IF (LHOOK) CALL DR_HOOK('ESMOOTHE',1,ZHOOK_HANDLE) RETURN ENDIF DO JFL = 1, KNUBI DO JLL = 1, IEND DO JLON = KDLUX,KDLON DO JLAT = KDGUN,KDGL ZPRAC(JLON,JLAT) = PWORK(JLON,JFL,JLAT) ENDDO ENDDO DO JLON = KDLUX,KDLON ZPRAC(JLON,KDGUN-1) = PWORK(JLON,JFL,KDGL) ZPRAC(JLON,KDGL +1) = PWORK(JLON,JFL,KDGUN) ENDDO DO JLAT = KDGUN,KDGL ZPRAC(KDLON+1,JLAT) = PWORK(KDLUN,JFL,JLAT) ENDDO ZPRAC(KDLON+1,KDGUN-1) = PWORK(KDLUN,JFL,KDGL) ZPRAC(KDLON+1,KDGL +1) = PWORK(KDLUN,JFL,KDGUN) DO JLON = KDLUX + JLL,IENX1 - JLL + 1 DO JLAT = KDGUN, IENX2 PWORK(JLON,JFL,JLAT)=(4._JPRB*ZPRAC(JLON,JLAT)+2.0_JPRB*(ZPRAC(JLON+& & 1,JLAT)+& & ZPRAC(JLON-1,JLAT) + ZPRAC(JLON,JLAT+1) +& & ZPRAC(JLON,JLAT-1)) + ZPRAC(JLON+1,JLAT+1) +& & ZPRAC(JLON-1,JLAT+1) + ZPRAC(JLON+1,JLAT-1)+& & ZPRAC(JLON-1,JLAT-1))/16._JPRB ENDDO ENDDO DO JLAT = KDGUX,KDGL DO JLON = KDLUN,KDLON ZPRAC(JLON,JLAT) = PWORK(JLON,JFL,JLAT) ENDDO ENDDO DO JLAT = KDGUX,KDGL ZPRAC(KDLUN-1,JLAT) = PWORK(KDLON,JFL,JLAT) ZPRAC(KDLON+1,JLAT) = PWORK(KDLUN,JFL,JLAT) ENDDO DO JLON = KDLUN,KDLON ZPRAC(JLON,KDGL +1) = PWORK(JLON,JFL,KDGUN) ENDDO ZPRAC(KDLUN-1,KDGL +1) = PWORK(KDLON,JFL,KDGUN) ZPRAC(KDLON+1,KDGL +1) = PWORK(KDLUN,JFL,KDGUN) DO JLAT = KDGUX + JLL, IENY1 - JLL + 1 DO JLON = KDLUN,IENY2 PWORK(JLON,JFL,JLAT)=(4._JPRB*ZPRAC(JLON,JLAT)+2.0_JPRB*(ZPRAC(JLON+& & 1,JLAT)+& & ZPRAC(JLON-1,JLAT) + ZPRAC(JLON,JLAT+1) +& & ZPRAC(JLON,JLAT-1)) + ZPRAC(JLON+1,JLAT+1) +& & ZPRAC(JLON-1,JLAT+1) + ZPRAC(JLON+1,JLAT-1)+& & ZPRAC(JLON-1,JLAT-1))/16._JPRB ENDDO ENDDO ENDDO ENDDO ! -------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ESMOOTHE',1,ZHOOK_HANDLE) END SUBROUTINE ESMOOTHE END MODULE ESMOOTHE_MOD ectrans-1.8.0/src/etrans/cpu/biper/internal/ewindowe_mod.F900000664000175000017500000001132115174631767024111 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE EWINDOWE_MOD CONTAINS SUBROUTINE EWINDOWE(KDLON,KDLUX,KBWX,KDGL,KDGUX,KBWY,KFLD,PGPIN,PSCAL,LDBIX,LDBIY) ! purpose : ! -------- ! Make boyd periodic extension. ! externals : ! ---------- ! None ! explicit arguments : ! ------------------ ! KDLON : upper bound for the x (or longitude) dimension ! of C U I U P. ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U P ! PGPIN : gridpoint array on C U I U P (gp:fields). ! PSCAL : window function scaling parameter ! LDBIX : .TRUE. windowing in x direction ( and vice versa ) ! LDBIY : .TRUE. windowing in y direction ( and vice versa ) ! references : ! ---------- ! author : Fabrice Voitus and Piet Termonia, 07/2009 ! ------ ! ! modification : ! Daan Degrauwe 02/2012 Cleaned and generalized ! S. Martinez 03/2012 Calls to ERF under CPP key __PGI ! (ERF function is not intrinsic with PGI) ! R. El Khatib 27-Sep-2013 implicit sized PGPIN ! R. El Khatib 04-Aug-2016 new interface ! ----------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KBWX INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KBWY INTEGER(KIND=JPIM),INTENT(IN) :: KFLD REAL(KIND=JPRB) ,INTENT(INOUT) :: PGPIN((KDLUX+2*KBWX+2*(KDLON-KDLUX))*(KDGUX+2*KBWY+2*(KDGL-KDGUX)),KFLD) REAL(KIND=JPRB) ,INTENT(IN) :: PSCAL LOGICAL ,INTENT(IN) :: LDBIX LOGICAL ,INTENT(IN) :: LDBIY ! FERF function ! ------------- #ifdef __PGI REAL(KIND=JPRB), EXTERNAL :: ERF #endif ! scalars ! -------- INTEGER(KIND=JPIM) :: JFL, JGL, JLON, IOFF, IDLW, IDGW INTEGER(KIND=JPIM) :: IWX, ILWX, IRWX, IWY, ILWY, IRWY, IBWXO, IBWYO INTEGER(KIND=JPIM) :: ILATF, ILONF, IND1, IND, IOFF_LEFT,IOFF_RIGHT,IOFF_BOTTOM,IOFF_TOP REAL(KIND=JPRB) :: ZI, ZJ, ZK, ZL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! local arrays : ! ------------ REAL(KIND=JPRB) :: ZBELX(2*KBWX+(KDLON-KDLUX)) REAL(KIND=JPRB) :: ZBELY(2*KBWY+(KDGL -KDGUX)) !* 1. Boyd Bi-periodic Extension Method. ! --------------------------------- IF (LHOOK) CALL DR_HOOK('EWINDOWE',0,ZHOOK_HANDLE) IF ((.NOT.LDBIX).AND.(.NOT.LDBIY)) THEN IF (LHOOK) CALL DR_HOOK('EWINDOWE',1,ZHOOK_HANDLE) RETURN ENDIF IDGW=SIZE(ZBELY) IDLW=SIZE(ZBELX) ! Bell window functions : ! --------------------- IF (LDBIX) THEN DO JLON=1,IDLW ! variable between -1 and 1 ZJ=REAL(-IDLW-1+2*JLON,JPRB)/(IDLW+1) ZL=ZJ/SQRT(1.0_JPRB-(ZJ*ZJ)) #ifdef __PGI ZBELX(JLON)=(1.0_JPRB+ERF(REAL(PSCAL*ZL)))/2.0_JPRB #else ZBELX(JLON)=(1.0_JPRB+ERF(PSCAL*ZL))/2.0_JPRB #endif ENDDO ENDIF IF (LDBIY) THEN DO JGL=1,IDGW ! variable between -1 and 1 ZJ=REAL(-IDGW-1+2*JGL,JPRB)/(IDGW+1) ZL=ZJ/SQRT(1.0_JPRB-(ZJ*ZJ)) #ifdef __PGI ZBELY(JGL)=(1.0_JPRB+ERF(REAL(PSCAL*ZL)))/2.0_JPRB #else ZBELY(JGL)=(1.0_JPRB+ERF(PSCAL*ZL))/2.0_JPRB #endif ENDDO ENDIF ! Windowing on P+G-zone : ! -------------------- IOFF=(KDLUX+2*(KBWX+KDGL-KDGUX)) IBWXO=KBWX+(KDLON-KDLUX) IBWYO=KBWY+(KDGL-KDGUX) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFL,JGL,JLON,ILONF,ILATF,IND1,IND,IOFF_LEFT,IOFF_RIGHT,IOFF_BOTTOM,IOFF_TOP) DO JFL=1,KFLD IF (LDBIX) THEN ! X-direction DO JGL=1,KDGL+IDGW IOFF_LEFT=(JGL-1)*IOFF IOFF_RIGHT=IOFF_LEFT+KDLON DO JLON=1,IDLW PGPIN(IOFF_RIGHT+JLON,JFL) = ZBELX(JLON)*PGPIN(IOFF_LEFT+JLON,JFL) +& & (1.0_JPRB-ZBELX(JLON))*PGPIN(IOFF_RIGHT+JLON,JFL) ENDDO ENDDO ENDIF IF (LDBIY) THEN ! Y-direction DO JGL=1,IDGW IOFF_BOTTOM=(JGL-1)*IOFF IOFF_TOP=(KDGL+JGL-1)*IOFF !DIR$ IVDEP DO JLON=1,KDLON+IDLW PGPIN(IOFF_TOP+JLON,JFL) = ZBELY(JGL)*PGPIN(IOFF_BOTTOM+JLON,JFL) +& & (1.0_JPRB-ZBELY(JGL))*PGPIN(IOFF_TOP+JLON,JFL) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO IF (LHOOK) CALL DR_HOOK('EWINDOWE',1,ZHOOK_HANDLE) END SUBROUTINE EWINDOWE END MODULE EWINDOWE_MOD ectrans-1.8.0/src/etrans/cpu/biper/external/0000775000175000017500000000000015174631767021161 5ustar alastairalastairectrans-1.8.0/src/etrans/cpu/biper/external/horiz_field.F900000664000175000017500000000445315174631767023745 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 HORIZ_FIELD(KX,KY,PHFIELD) ! purpose : ! -------- ! To produce test horizontal field of temperature. ! method : ! --------- ! Test horizontal input field is on horizontal grid size KXxKY points, and it ! represent's temperature. It is obtained form flollwing expression: ! PHFIELD(i,j)=280*(1+0.1*Sin[PPI*(i+0.5*IMAX)*(j+0.7*IMAX)/IMAX^2+1]) (Pierre Benard) ! interface : ! --------- ! CALL HORIZ_FIELD(KX,KY,PHFIELD) ! Explicit arguments : ! ------------------- ! KX - number of grid points in x ! KY - number of grid points in y ! PHFIELD - simulated 2D temperature horizontal field ! externals : ! ---------- ! None. ! references : ! ---------- ! author : ! ------ ! 23-May-2008 Antonio Stanesic ! ---------------------------------------------------------------------- USE PARKIND1 , ONLY : JPIM ,JPRB USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KX INTEGER(KIND=JPIM), INTENT(IN) :: KY REAL(KIND=JPRB), INTENT(OUT) :: PHFIELD(KX,KY) ! ---------------------------------------------------------------------- REAL(KIND=JPRB), PARAMETER :: PPI=3.141592 INTEGER(KIND=JPIM) :: JX,JY,IMAX REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('HORIZ_FIELD',0,ZHOOK_HANDLE) ! ---------------------------------------------------------------------- IMAX=MAX(KX,KY) DO JY=1,KY DO JX=1,KX PHFIELD(JX,JY)=280*(1+0.1*SIN(PPI*(JX+0.5*IMAX)*(JY+0.7*IMAX)/(IMAX**2)+1)) ENDDO ENDDO ! ---------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('HORIZ_FIELD',1,ZHOOK_HANDLE) END SUBROUTINE HORIZ_FIELD ectrans-1.8.0/src/etrans/cpu/biper/external/etibihie.F900000664000175000017500000000777215174631767023240 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 ETIBIHIE(KDLON,KDGL,KNUBI,KDLUX,KDGUX,& & KSTART,KDLSM,PGPBI,LDBIX,LDBIY,KDADD) !**** tool ETIBIHIE : Doubly-periodicisation : isotropic spline ! ------------- method. ! purpose : ! -------- ! KNUBI horizontal fields which are known on C U I, ! are extended over E, in order to obtain doubly-periodic ! fields. ! IF LDBIX is equal .TRUE. , then the fields are periodicise ! in the x ( or longitude ) direction. If it is not the case, ! KDLUX must be equal to KDLON. ! IF LDBIY is equal .TRUE. , then the fields are periodicise ! in the y ( or latitude ) direction. If it is not the case, ! KDGUX must be equal to KDGL. !* *CALL* *ETIBIHIE*(...) ! externals : ! ---------- ! ESPLIN spline extension ! ESMOOTH smoothing across to get isotropy. ! explicit arguments : ! ------------------ ! KDLON : upper bound for the x (or longitude) dimension ! of the gridpoint array on C U I U E ! KDGL : upper bound for the y (or latitude) dimension ! of the gridpoint array on C U I U E ! KNUBI : number of horizontal fields to doubly-periodicise. ! KDLUX : upper bound for the x (or longitude) dimension ! of C U I. ! KDGUX : upper bound for the y (or latitude) dimension ! of C U I. ! KSTART : first dimension in x direction of g-p array ! KDLSM : second dimension in x direction of g-p array ! PGPBI : gridpoint array on C U I U E. ! LDBIX : logical to periodicize or not ! in the x ( or longitude ) direction. ! LDBIY : logical to periodicize or not ! in the y ( or latitude ) direction. ! KDADD : 1 to test biperiodiz. ! references : ! ---------- ! author : ! ------ ! V. Ducrocq ! modification : ! ------------ ! A. Stanesic 28/03/2008: KDADD - test of externalized biper. ! ------------------------------------------------------------------------- USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE ESPLINE_MOD USE ESMOOTHE_MOD ! ------------------------------------------------------------------------- IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KSTART INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KDADD REAL(KIND=JPRB),INTENT(INOUT) :: PGPBI(KSTART:KDLSM+KDADD,KNUBI,1:KDGL+KDADD) LOGICAL,INTENT(IN) :: LDBIX LOGICAL,INTENT(IN) :: LDBIY ! ------------------------------------------------------------------------- REAL(KIND=JPRB) :: ZALFA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ETIBIHIE',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------------- !* 1. DOUBLY-PERIODICISE : ! ------------------ ZALFA = 0.0_JPRB CALL ESPLINE(1,KDLON,1,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM+KDADD,1,KDGL+KDADD,KNUBI,PGPBI,ZALFA,LDBIX,LDBIY,KDADD) CALL ESMOOTHE(1,KDLON,1,KDGL,KDLUX,KDGUX,KSTART,& & KDLSM+KDADD,1,KDGL+KDADD,KNUBI,PGPBI,LDBIX,LDBIY) ! ------------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('ETIBIHIE',1,ZHOOK_HANDLE) END SUBROUTINE ETIBIHIE ectrans-1.8.0/src/etrans/cpu/biper/external/fpbipere.F900000664000175000017500000001275115174631767023243 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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 FPBIPERE(KDLUX,KDGUX,KDLON,KDGL,KNUBI,KD1,PGPBI,KDADD,LDZON, & & LDBOYD, KDBOYD, PLBOYD) !**** *FPBIPERE* - Full-POS interface for double periodicisation ! purpose : ! -------- ! To bi-periodicise the post-processed fields, or just fill the extension zone ! with the mean value of C+I area !** INTERFACE. ! ---------- ! *CALL* *FPBIPERE*(...) ! EXPLICIT ARGUMENTS ! -------------------- ! KDLUX : upper bound for the x (or longitude) dimension of C U I. ! KDGUX : upper bound for the y (or latitude) dimension of C U I. ! KDLON : upper bound for the x (or longitude) dimension of the gridpoint array on C U I U E ! KDGL : upper bound for the y (or latitude) dimension of the gridpoint array on C U I U E ! KNUBI : number of horizontal fields to doubly-periodicise. ! KD1 : dimension of input/output array ! PGPBI : input/output gridpoint array on C U I U E. ! LDZON : .true. if input grid on C U I U E (.false. if C U I) ! KDADD : 1 to test biperiodiz. ! LDBOYD: perform boyd periodization (inside C U I) ! KDBOYD: array containing dimensions of boyd domain ! PLBOYD: scalar parameter for boyd (variable L in paper) ! IMPLICIT ARGUMENTS ! -------------------- ! METHOD. ! ------- ! SEE DOCUMENTATION ! EXTERNALS. ! ---------- ! ESPLINE spline extension ! ESMOOTHE smoothing across to get isotropy. ! REFERENCE. ! ---------- ! ECMWF Research Department documentation of the IFS ! AUTHOR. ! ------- ! RYAD EL KHATIB *METEO-FRANCE* ! MODIFICATIONS. ! -------------- ! R. El Khatib : 01-08-07 Pruning options ! M.Hamrud : 01-Oct-2003 CY28 Cleaning ! F. Taillefer : 04-10-21 Add LDZON ! A. Stanesic : 28-03-08: KDADD - test of externalized biper. ! D. Degrauwe : feb 2012 Boyd periodization ! R. El Khatib 27-Sep-2013 Boyd periodization in Fullpos-2 ! R. El Khatib 04-Aug-2016 new interface to ewindowe + cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE ESPLINE_MOD USE ESMOOTHE_MOD USE EWINDOWE_MOD ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KD1 INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDADD REAL(KIND=JPRB) ,INTENT(INOUT) :: PGPBI(KD1,KNUBI) LOGICAL, OPTIONAL ,INTENT(IN) :: LDZON LOGICAL ,INTENT(IN) ,OPTIONAL :: LDBOYD INTEGER(KIND=JPIM),INTENT(IN) ,OPTIONAL :: KDBOYD(6) REAL(KIND=JPRB) ,INTENT(IN) ,OPTIONAL :: PLBOYD ! ------------------------------------------------------------------ REAL(KIND=JPRB), ALLOCATABLE :: ZGPBI(:,:,:) INTEGER(KIND=JPIM) :: IND, ISTAE, JGL, JLON, JNUBI, ILONF, ILATF, IBWX, IBWY INTEGER(KIND=JPIM) :: IBWXH, IBWYH, IND1 INTEGER(KIND=JPIM) :: ILONI(KDLON), ILATI(KDGL) INTEGER(KIND=JPIM) :: IDLUN, IDGUN, IDLUX, IDGUX LOGICAL :: LLZON, LLBOYD REAL(KIND=JPRB) :: ZALFA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE #include "abor1.intfb.h" ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('FPBIPERE',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ LLBOYD=.FALSE. IF (PRESENT(LDBOYD)) LLBOYD=LDBOYD !* 2. DOUBLY-PERIODICISE ! ------------------ IF (LLBOYD) THEN IF (.NOT.PRESENT(KDBOYD)) CALL ABOR1('FPBIPERE: Boyd periodization requires KDBOYD argument') IF (.NOT.PRESENT(PLBOYD)) CALL ABOR1('FPBIPERE: Boyd periodization requires PLBOYD argument') IBWX=KDBOYD(3) IBWY=KDBOYD(6) CALL EWINDOWE(KDLON,KDLUX,IBWX,KDGL,KDGUX,IBWY,KNUBI,PGPBI,PLBOYD,.TRUE.,.TRUE.) ELSE LLZON=.FALSE. IF(PRESENT(LDZON)) LLZON=LDZON ALLOCATE(ZGPBI(KDLON+KDADD,KNUBI,KDGL+KDADD)) IF(LLZON) THEN ! Copy C+I+E IND=KDLON ELSE ! Copy C+I IND=KDLUX ENDIF !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JNUBI,ISTAE,JGL,JLON) DO JNUBI=1,KNUBI ISTAE=0 DO JGL=1,KDGUX DO JLON=1,KDLUX ZGPBI(JLON,JNUBI,JGL)=PGPBI(ISTAE+JLON,JNUBI) ENDDO ISTAE=ISTAE+IND ENDDO ENDDO !$OMP END PARALLEL DO ZALFA = 0.0_JPRB CALL ESPLINE(1,KDLON,1,KDGL,KDLUX,KDGUX,1,KDLON+KDADD,1,KDGL+KDADD,KNUBI,ZGPBI,& & ZALFA,.TRUE.,.TRUE.,KDADD) CALL ESMOOTHE(1,KDLON,1,KDGL,KDLUX,KDGUX,1,KDLON+KDADD,1,KDGL+KDADD,KNUBI,ZGPBI,& & .TRUE.,.TRUE.) !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JNUBI,ISTAE,JGL,JLON) DO JNUBI=1,KNUBI ISTAE=0 DO JGL=1,KDGL DO JLON=1,KDLON PGPBI(ISTAE+JLON,JNUBI)=ZGPBI(JLON,JNUBI,JGL) ENDDO ISTAE=ISTAE+KDLON ENDDO ENDDO !$OMP END PARALLEL DO DEALLOCATE(ZGPBI) ENDIF ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('FPBIPERE',1,ZHOOK_HANDLE) END SUBROUTINE FPBIPERE ectrans-1.8.0/src/etrans/include/0000775000175000017500000000000015174631767017072 5ustar alastairalastairectrans-1.8.0/src/etrans/include/etrans/0000775000175000017500000000000015174631767020366 5ustar alastairalastairectrans-1.8.0/src/etrans/include/etrans/einv_trans.h0000664000175000017500000001752515174631767022721 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EINV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & FSPGL_PROC,& & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,KPROMA,KVSETUV,KVSETSC,KRESOL,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) !**** *EINV_TRANS* - Inverse spectral transform. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform !** Interface. ! ---------- ! CALL EINV_TRANS(...) ! Explicit arguments : All arguments 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. ESET_RESOL - set resolution ! ---------- ELTINV_CTL - control of Legendre transform ! EFTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields ! and derivatives (IF_SCALARS_G) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: 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(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANU(:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANV(:) END SUBROUTINE EINV_TRANS END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/etrans_end.h0000664000175000017500000000237115174631767022664 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE ETRANS_END(CDMODE) !**** *ETRANS_END* - Terminate transform package ! Purpose. ! -------- ! Terminate transform package. Release all allocated arrays. !** Interface. ! ---------- ! CALL ETRANS_END ! Explicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing cy37 after G.Radnoti ! ------------------------------------------------------------------ IMPLICIT NONE CHARACTER*5, OPTIONAL, INTENT(IN) :: CDMODE END SUBROUTINE ETRANS_END END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/einv_transad.h0000664000175000017500000001736415174631767023227 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EINV_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,PMEANU,PMEANV) !**** *EINV_TRANSAD* - Inverse spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform - adjoint !** Interface. ! ---------- ! CALL EINV_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. ESET_RESOL - set resolution ! ---------- ELTDIR_CTLAD - control of Legendre transform ! EFTDIR_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB 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(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANV(:) END SUBROUTINE EINV_TRANSAD END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/edir_trans.h0000664000175000017500000001506415174631767022677 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EDIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV,AUX_PROC) !**** *EDIR_TRANS* - Direct spectral transform (from grid-point to spectral). ! Purpose. ! -------- ! Interface routine for the direct spectral transform !** Interface. ! ---------- ! CALL EDIR_TRANS(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! PMEANU(:),PMEANV(:) - mean wind ! AUX_PROC - optional external procedure for biperiodization of ! aux.fields ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB 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(:,:) 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 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(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANU(:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PMEANV(:) EXTERNAL AUX_PROC OPTIONAL AUX_PROC END SUBROUTINE EDIR_TRANS END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/edist_grid.h0000664000175000017500000000405015174631767022653 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EDIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) !**** *EDIST_GRID* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL EDIST_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:) - Local spectral array ! ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- DIST_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) ! ------------------------------------------------------------------ END SUBROUTINE EDIST_GRID END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/horiz_field.h0000664000175000017500000000136115174631767023036 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE HORIZ_FIELD(KX,KY,PHFIELD) USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KX INTEGER(KIND=JPIM), INTENT(IN) :: KY REAL(KIND=JPRB), INTENT(OUT) :: PHFIELD(KX,KY) REAL(KIND=JPRB), PARAMETER :: PPI=3.141592 END SUBROUTINE HORIZ_FIELD END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/fpbipere.h0000664000175000017500000000223415174631767022334 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE FPBIPERE(KDLUX,KDGUX,KDLON,KDGL,KNUBI,KD1,PGPBI,KDADD,LDZON,& & LDBOYD,KDBOYD,PLBOYD,PBIPOUT) USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KD1 INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDADD REAL(KIND=JPRB) ,INTENT(INOUT):: PGPBI(KD1,KNUBI) LOGICAL, OPTIONAL ,INTENT(IN) :: LDZON LOGICAL, OPTIONAL ,INTENT(IN) :: LDBOYD INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KDBOYD(6) REAL(KIND=JPRB) , INTENT(IN), OPTIONAL :: PLBOYD REAL(KIND=JPRB) ,INTENT(OUT), OPTIONAL :: PBIPOUT(:,:) END SUBROUTINE FPBIPERE END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/esetup_trans.h0000664000175000017500000000740615174631767023262 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE ESETUP_TRANS(KMSMAX,KSMAX,KDGL,KDGUX,KLOEN,LDSPLIT,& & KTMAX,KRESOL,PEXWN,PEYWN,PWEIGHT,LDGRIDONLY,KNOEXTZL,KNOEXTZG,& & LDUSEFFTW,LD_ALL_FFTW) !**** *ESETUP_TRANS* - Setup transform package for specific resolution ! Purpose. ! -------- ! To setup for making spectral transforms. Each call to this routine ! creates a new resolution up to a maximum of NMAX_RESOL set up in ! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can ! be called. !** Interface. ! ---------- ! CALL ESETUP_TRANS(...) ! Explicit arguments : KLOEN,LDSPLIT are optional arguments ! -------------------- ! KSMAX - spectral truncation required ! KDGL - number of Gaussian latitudes ! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] ! LDSPLIT - true if split latitudes in grid-point space [false] ! KTMAX - truncation order for tendencies? ! KRESOL - the resolution identifier ! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution ! in spectral and grid-point space ! LDGRIDONLY - true if only grid space is required ! LDSPLIT describe the distribution among processors of ! grid-point data and has no relevance if you are using a single processor ! LDUSEFFTW - Use FFTW for FFTs ! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ESETUP_DIMS - setup distribution independent dimensions ! SUEMP_TRANS_PRELEG - first part of setup of distr. environment ! SULEG - Compute Legandre polonomial and Gaussian ! Latitudes and Weights ! ESETUP_GEOM - Compute arrays related to grid-point geometry ! SUEMP_TRANS - Second part of setup of distributed environment ! SUEFFT - setup for FFT ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 02-04-11 A. Bogatchev: Passing of TCDIS ! 02-11-14 C. Fischer: soften test on KDGL ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing cy37 ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KMSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(:) LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT LOGICAL ,OPTIONAL,INTENT(IN) :: LDGRIDONLY INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KTMAX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEXWN REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PEYWN REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZL INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KNOEXTZG LOGICAL ,OPTIONAL,INTENT(IN) :: LDUSEFFTW LOGICAL ,OPTIONAL,INTENT(IN) :: LD_ALL_FFTW END SUBROUTINE ESETUP_TRANS END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/edist_spec.h0000664000175000017500000000415215174631767022663 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EDIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& & LDIM1_IS_FLD,KSORT) !**** *EDIST_SPEC* - Distribute global spectral array among processors ! Purpose. ! -------- ! Interface routine for distributing spectral array !** Interface. ! ---------- ! CALL EDIST__SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PSPEC(:,:) - Local spectral array ! ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- EDIST_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) ! ------------------------------------------------------------------ END SUBROUTINE EDIST_SPEC END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/egath_spec.h0000664000175000017500000000444715174631767022652 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EGATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,KMSMAX,LDZA0IP) !**** *EGATH_SPEC* - Gather global spectral array from processors ! Purpose. ! -------- ! Interface routine for gathering spectral array !** Interface. ! ---------- ! CALL EGATH_SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for gathering each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PSPEC(:,:) - Local spectral array ! LDIM1_IS_FLD - If TRUE first dimension of PSCPEC and PSPECG is the field dimension [.T.] ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- EGATH_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMSMAX LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP ! ------------------------------------------------------------------ END SUBROUTINE EGATH_SPEC END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/edir_transad.h0000664000175000017500000001450215174631767023200 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EDIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2,PMEANU,PMEANV) !**** *EDIR_TRANSAD* - Direct spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the direct spectral transform - adjoint !** Interface. ! ---------- ! CALL EDIR_TRANSAD(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- EDIR_TRANS_CTLAD - control routine ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) 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 REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANU(:) REAL(KIND=JPRB),OPTIONAL ,INTENT(IN) :: PMEANV(:) END SUBROUTINE EDIR_TRANSAD END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/especnorm.h0000664000175000017500000000363315174631767022537 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE ESPECNORM(PSPEC,KVSET,KMASTER,KRESOL,PMET,PNORM) !**** *ESPECNORM* - Compute global spectral norms ! Purpose. ! -------- ! Interface routine for computing spectral norms !** Interface. ! ---------- ! CALL ESPECNORM(...) ! Explicit arguments : All arguments optional ! -------------------- ! PSPEC(:,:) - Spectral array ! KVSET(:) - "B-Set" for each field ! KMASTER - processor to recieve norms ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PMET(:) - metric ! PNORM(:) - Norms (output for processor KMASTER) ! ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ESPNORM_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PNORM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL ! ------------------------------------------------------------------ END SUBROUTINE ESPECNORM END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/etrans_inq.h0000664000175000017500000002061415174631767022705 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE ETRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& & KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& & KMYMS,KESM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& & KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& & KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& & KULTPP,KPTRLS,& & KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& & LDSPLITLAT,LDLINEAR_GRID,& & KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,KDEF_RESOL,LDLAM,& & PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KCPL2M,KCPL4M,KPROCM) !**** *ETRANS_INQ* - Extract information from the transform package ! Purpose. ! -------- ! Interface routine for extracting information from the T.P. !** Interface. ! ---------- ! CALL ETRANS_INQ(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resulution (input) ! MULTI-TRANSFORMS MANAGEMENT ! KDEF_RESOL - number or resolutions defined ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! SPECTRAL SPACE ! KSPEC - number of complex spectral coefficients on this PE ! KSPEC2 - 2*KSPEC ! KSPEC2G - global KSPEC2 ! KSPEC2MX - maximun KSPEC2 among all PEs ! KNUMP - Number of spectral waves handled by this PE ! KGPTOT - Total number of grid columns on this PE ! KGPTOTG - Total number of grid columns on the Globe ! KGPTOTMX - Maximum number of grid columns on any of the PEs ! KGPTOTL - Number of grid columns one each PE (dimension N_REGIONS_NS:N_REGIONS_EW) ! KMYMS - This PEs spectral zonal wavenumbers ! KESM0 - Address in a spectral array of (m, n=m) ! KUMPP - No. of wave numbers each wave set is responsible for ! KPOSSP - Defines partitioning of global spectral fields among PEs ! KPTRMS - Pointer to the first wave number of a given a-set ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KSMAX - spectral truncation - n direction ! KMSMAX - spectral truncation - m direction ! KNVALUE - n value for each KSPEC2 spectral coeffient ! KMVALUE - m value for each KSPEC2 spectral coeffient ! LDLINEAR_GRID : .TRUE. if the grid is linear ! GRIDPOINT SPACE ! KFRSTLAT - First latitude of each a-set in grid-point space ! KLSTTLAT - Last latitude of each a-set in grid-point space ! KFRSTLOFF - Offset for first lat of own a-set in grid-point space ! KPTRLAT - Pointer to the start of each latitude ! KPTRFRSTLAT - Pointer to the first latitude of each a-set in ! NSTA and NONL arrays ! KPTRLSTLAT - Pointer to the last latitude of each a-set in ! NSTA and NONL arrays ! KPTRFLOFF - Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 ! KSTA - Position of first grid column for the latitudes on a ! processor. The information is available for all processors. ! The b-sets are distinguished by the last dimension of ! nsta().The latitude band for each a-set is addressed by ! nptrfrstlat(jaset),nptrlstlat(jaset), and ! nptrfloff=nptrfrstlat(myseta) on this processors a-set. ! Each split latitude has two entries in nsta(,:) which ! necessitates the rather complex addressing of nsta(,:) ! and the overdimensioning of nsta by N_REGIONS_NS. ! KONL - Number of grid columns for the latitudes on a processor. ! Similar to nsta() in data structure. ! LDSPLITLAT - TRUE if latitude is split in grid point space over ! two a-sets ! FOURIER SPACE ! KULTPP - number of latitudes for which each a-set is calculating ! the FFT's. ! KPTRLS - pointer to first global latitude of each a-set for which ! it performs the Fourier calculations ! LEGENDRE ! PMU - sin(Gaussian latitudes) ! PGW - Gaussian weights ! PRPNM - Legendre polynomials ! KLEI3 - First dimension of Legendre polynomials ! KSPOLEGL - Second dimension of Legendre polynomials ! KPMS - Adress for legendre polynomial for given M (NSMAX) ! PLEPINM - Eigen-values of the inverse Laplace operator ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! A.Nmiri 15-Nov-2007 Phasing with TFL 32R3 ! A.Bogatchev 16-Sep-2010 Phasing with TFL 36R4 ! R. El Khatib 08-Aug-2012 KSMAX,KMSMAX,KNVALUE,KMVALUE,PLEPINM,LDLAM,KDEF_RESOL,LDLINEAR_GRID ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KRESOL INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2 INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2G INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPEC2MX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KNUMP INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOT INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTG INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTMX INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KGPTOTL(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KMYMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KESM0(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KUMPP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPOSSP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KALLMS(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KDIM0G(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KFRSTLOFF INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRFLOFF INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSTA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KONL(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KULTPP(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPTRLS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW LOGICAL ,OPTIONAL,INTENT(INOUT) :: LDSPLITLAT(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PMU(:) REAL(KIND=JPRB) ,OPTIONAL :: PGW(:) ! Argument NOT used REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PRPNM(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KLEI3 INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KSPOLEGL INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPMS(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL2M(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KCPL4M(0:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(INOUT) :: KPROCM(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMVALUE(:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PLEPINM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLINEAR_GRID END SUBROUTINE ETRANS_INQ END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/egpnorm_trans.h0000664000175000017500000000437615174631767023427 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EGPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !**** *EGPNORM_TRANS* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL EGPNORM_TRANS(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! A.Bogatchev after gpnorm_trans ! Modifications. ! -------------- ! Original : 12th Jun 2009 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB),INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB),INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB),INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB),INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL,INTENT(IN) :: LDAVE_ONLY INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL END SUBROUTINE EGPNORM_TRANS END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/egath_grid.h0000664000175000017500000000372215174631767022640 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE EGATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *EGATH_GRID* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL EGATH_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:,:) - Local spectral array ! ! Method. ! ------- ! Externals. ESET_RESOL - set resolution ! ---------- GATH_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(IN) :: PGP(:,:,:) ! ------------------------------------------------------------------ END SUBROUTINE EGATH_GRID END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/etibihie.h0000664000175000017500000000233715174631767022326 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE ETIBIHIE(KDLON,KDGL,KNUBI,KDLUX,KDGUX,& & KSTART,KDLSM,PGPBI,LDBIX,LDBIY,KDADD) USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUBI INTEGER(KIND=JPIM),INTENT(IN) :: KSTART INTEGER(KIND=JPIM),INTENT(IN) :: KDLSM INTEGER(KIND=JPIM),INTENT(IN) :: KDLON INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KDLUX INTEGER(KIND=JPIM),INTENT(IN) :: KDGUX INTEGER(KIND=JPIM),INTENT(IN) :: KDADD REAL(KIND=JPRB),INTENT(INOUT) :: PGPBI(KSTART:KDLSM+KDADD,KNUBI,1:KDGL+KDADD) LOGICAL,INTENT(IN) :: LDBIX LOGICAL,INTENT(IN) :: LDBIY END SUBROUTINE ETIBIHIE END INTERFACE ectrans-1.8.0/src/etrans/include/etrans/etrans_release.h0000664000175000017500000000111415174631767023530 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! INTERFACE SUBROUTINE ETRANS_RELEASE(KRESOL) USE PARKIND1 ,ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL END SUBROUTINE ETRANS_RELEASE END INTERFACE ectrans-1.8.0/src/etrans/CMakeLists.txt0000664000175000017500000001056315174631767020214 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. function(generate_file) set (options) set (oneValueArgs INPUT OUTPUT BACKEND) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(output ${_PAR_OUTPUT}) set(input ${_PAR_INPUT}) set(backend ${_PAR_BACKEND}) set(sed_rules ${PROJECT_SOURCE_DIR}/src/etrans/sedrenames.txt) set( JPRB_dp JPRD ) set( jprb_dp jprd ) set( JPRB_sp JPRM ) set( jprb_sp jprm ) set( JPRB_gpu_dp JPRD ) set( jprb_gpu_dp jprd ) set( JPRB_gpu_sp JPRM ) set( jprb_gpu_sp jprm ) add_custom_command( OUTPUT ${output} COMMAND cat ${sed_rules} | sed -e "s/VARIANTDESIGNATOR/${backend}/g" | sed -e "s/TYPEDESIGNATOR_UPPER/${JPRB_${backend}}/g" | sed -e "s/TYPEDESIGNATOR_LOWER/${jprb_${backend}}/g" | sed -rf - ${input} > ${output} DEPENDS ${input} ${sed_rules} COMMENT "Generating ${output}" VERBATIM ) endfunction(generate_file) function(generate_backend_includes) set (options) set (oneValueArgs BACKEND TARGET DESTINATION INCLUDE_DIRECTORY) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(destination ${_PAR_DESTINATION} ) set(backend ${_PAR_BACKEND}) file(MAKE_DIRECTORY ${destination}) file(MAKE_DIRECTORY ${destination}/etrans_${backend}) ecbuild_list_add_pattern( LIST absolute_files GLOB etrans/*.h SOURCE_DIR ${_PAR_INCLUDE_DIRECTORY} QUIET ) set( files ) foreach(file_i ${absolute_files}) file(RELATIVE_PATH file_i ${_PAR_INCLUDE_DIRECTORY} ${file_i}) list(APPEND files ${file_i}) endforeach() set( outfiles ) foreach(file_i ${files}) get_filename_component(outfile_name ${file_i} NAME) get_filename_component(outfile_name_we ${file_i} NAME_WE) get_filename_component(outfile_ext ${file_i} EXT) get_filename_component(outfile_dir ${file_i} DIRECTORY) if (${file_i} IN_LIST ectrans_lam_common_includes) configure_file(${_PAR_INCLUDE_DIRECTORY}/${file_i} ${destination}/${outfile_name}) else() set(outfile "${destination}/${outfile_name_we}_${backend}${outfile_ext}") ecbuild_debug("Generate ${outfile}") generate_file(BACKEND ${backend} INPUT ${_PAR_INCLUDE_DIRECTORY}/${file_i} OUTPUT ${outfile}) list(APPEND outfiles ${outfile}) string(TOUPPER ${outfile_name_we} OUTFILE_NAME_WE ) ecbuild_debug("Generate ${destination}/etrans_${backend}/${outfile_name}") file(WRITE ${destination}/etrans_${backend}/${outfile_name} "! Automatically generated interface header for backward compatibility of generic symbols !\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#if defined(${outfile_name_we})\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#undef ${outfile_name_we}\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#endif\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#if defined(${OUTFILE_NAME_WE})\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#undef ${OUTFILE_NAME_WE}\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#endif\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#include \"${outfile_name_we}_${backend}${outfile_ext}\"\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#define ${outfile_name_we} ${OUTFILE_NAME_WE}_${backend}\n") file(APPEND ${destination}/etrans_${backend}/${outfile_name} "#define ${OUTFILE_NAME_WE} ${OUTFILE_NAME_WE}_${backend}\n") endif() endforeach(file_i) add_custom_target(${_PAR_TARGET}_generate DEPENDS ${outfiles}) ecbuild_add_library(TARGET ${_PAR_TARGET} TYPE INTERFACE) add_dependencies(${_PAR_TARGET} ${_PAR_TARGET}_generate) target_include_directories(${_PAR_TARGET} INTERFACE $) endfunction(generate_backend_includes) add_subdirectory( common ) if( HAVE_CPU ) add_subdirectory( cpu ) endif() if( HAVE_ETRANS_GPU ) add_subdirectory( gpu ) endif() ectrans-1.8.0/src/trans/0000775000175000017500000000000015174631767015302 5ustar alastairalastairectrans-1.8.0/src/trans/common/0000775000175000017500000000000015174631767016572 5ustar alastairalastairectrans-1.8.0/src/trans/common/internal/0000775000175000017500000000000015174631767020406 5ustar alastairalastairectrans-1.8.0/src/trans/common/internal/interpol_decomp_mod.F900000664000175000017500000001630515174631767024715 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE INTERPOL_DECOMP_MOD ! Compute Interpolative Decomposions (ID) ! See Cheng,H., Gimbutas,Z., Martinsson,P.G. and Rokhlin,V. (2005) ! "On the compression of low rank matrices", SIAM.J.Sci.Comput., ! Vol. 26, No. 4, pp1389-1404 ! Also lecture notes "Mulilevel compression of Linear Operators: ! Descendents of Fast Multiple Methods and Calderon-Zygmund Theory" ! P.G.Martinsson and Mark Tygert, 2011. Chapter 7. ! Author: Mats Hamrud USE EC_PARKIND, ONLY : JPIM, JPRD, JPIB IMPLICIT NONE CONTAINS !=========================================================================== SUBROUTINE COMPUTE_ID(PEPS,KM,KN,PMAT,KRANK,KBCLIST,PNONIM) IMPLICIT NONE ! Compute ID REAL(KIND=JPRD),INTENT(IN) :: PEPS ! Precision for computation ! of numerical rank INTEGER(KIND=JPIM),INTENT(IN) :: KM ! Number of rows in matrix pmat INTEGER(KIND=JPIM),INTENT(IN) :: KN ! Number of columns in matrix pmat REAL(KIND=JPRD) ,INTENT(IN) :: PMAT(:,:) ! Original matrix INTEGER(KIND=JPIM),INTENT(OUT) :: KRANK ! Numerical rank INTEGER(KIND=JPIM),INTENT(OUT) :: KBCLIST(:) ! List of columns REAL(KIND=JPRD) ,INTENT(OUT) :: PNONIM(:,:) ! Non-identity part of projection ! matrix INTEGER(KIND=JPIM) :: JM,JN REAL(KIND=JPRD) :: ZR(KM,KN) REAL(KIND=JPRD),ALLOCATABLE :: ZS(:,:),ZT(:,:) !---------------------------------------------------------------------------- !Avoid destroying input matrix ZR(:,:) = PMAT(1:KM,1:KN) ! Householder QR CALL ALG541(PEPS,KM,KN,ZR,KRANK,KBCLIST) DO JN=1,KN DO JM=JN+1,KM ZR(JM,JN) = 0.0_JPRD ENDDO ENDDO ! S leftmost kxk block of R ALLOCATE(ZS(KRANK,KRANK)) DO JN=1,KRANK DO JM=1,KRANK IF(JM <= KM ) THEN ZS(JM,JN) = ZR(JM,JN) ELSE ZS(JM,JN) = 0.0_JPRD ENDIF ENDDO ENDDO ! T Rightmost kx(k-n) block of R ALLOCATE(ZT(KRANK,KN-KRANK)) DO JN=1,KN-KRANK DO JM=1,KRANK IF(JM <= KM ) THEN ZT(JM,JN) = ZR(JM,JN+KRANK) ELSE ZT(JM,JN) = 0.0_JPRD ENDIF ENDDO ENDDO !Solve linear equation (BLAS level 3 routine) IF( KRANK <= 0 ) THEN write(0,*) 'warning: KRANK DTRSM ', KRANK, KM, KN CALL ABOR1('DTRSM : KRANK <=0 not allowed') ENDIF ! IF (JPRB == JPRD) THEN CALL DTRSM('Left','Upper','No transpose','Non-unit',KRANK,KN-KRANK,1.0_JPRD, & & ZS,KRANK,ZT,KRANK) ! ELSE ! CALL STRSM('Left','Upper','No transpose','Non-unit',KRANK,KN-KRANK,1.0_JPRD, & ! & ZS,KRANK,ZT,KRANK) ! ENDIF DO JM=1,KRANK DO JN=1,KN-KRANK PNONIM(JM,JN) = ZT(JM,JN) ENDDO ENDDO DEALLOCATE(ZS,ZT) !!$IF(KRANK < KN) THEN !!$ PRINT *,'MAXVAL PNONIM ',KM,KM,KRANK,MAXVAL( PNONIM(1:KRANK,1:KN-KRANK)) !!$ENDIF END SUBROUTINE COMPUTE_ID !============================================================================== SUBROUTINE ALG541(PEPS,KM,KN,PA,KRANK,KLIST) IMPLICIT NONE ! Householder QR with Column Pivoting ! Algorithm 5.4.1 from Matrix Computations, G.H.Golub & C.F van Loen, third ed. ! Algorithm modified to terminate at numerical precision "peps" REAL(KIND=JPRD),INTENT(IN) :: PEPS ! Precision INTEGER(KIND=JPIM),INTENT(IN) :: KM ! Number of rows in matrix pa INTEGER(KIND=JPIM),INTENT(IN) :: KN ! Number of columns in matrix pa REAL(KIND=JPRD),INTENT(INOUT) :: PA(:,:) ! On input : original matrix ! on output : R in upper triangle etc ! see Golub&Van Loen INTEGER(KIND=JPIM),INTENT(OUT) :: KRANK ! Numerical rank of matrix INTEGER(KIND=JPIM),INTENT(OUT) :: KLIST(:) ! List of columns (pivots) INTEGER(KIND=JPIM) :: JN,ISWAP,IK,IM,IN,IMIN,ILIST(KN) REAL(KIND=JPRD) :: ZC(KN),ZTAU,ZSWAPA(KM),ZSWAP,ZV(KM),ZBETA,ZWORK(KN),ZTAU_IN REAL(KIND=JPRD) :: ZTAU_REC,ZEPS !------------------------------------------------------------------------------- ZEPS = 10000.0_JPRD*EPSILON(ZEPS) IMIN=MIN(KM,KN) ! Compute initial column norms,its max and the first column where c=tau IK = 0 ZTAU = 0._JPRD DO JN=1,KN ZC(JN) = DOT_PRODUCT(PA(1:KM,JN),PA(1:KM,JN)) IF(ZC(JN) > ZTAU) THEN IK = JN ZTAU = ZC(JN) ENDIF ENDDO ZTAU_IN = ZTAU ZTAU_REC= ZTAU KRANK = 0 DO WHILE (ZTAU > PEPS**2*ZTAU_IN) KRANK = KRANK+1 IF( KRANK <= IMIN ) THEN ILIST(KRANK) = IK ! Column swap KRANK with IK ZSWAPA(:) = PA(:,KRANK) PA(:,KRANK) = PA(:,IK) PA(:,IK) = ZSWAPA(:) ZSWAP = ZC(KRANK) ZC(KRANK) = ZC(IK) ZC(IK) = ZSWAP ! Compute Householder vector ZBETA=0.0_JPRD IF( KM-KRANK >= 0 ) THEN CALL ALG511(ZEPS,KM-KRANK+1,PA(KRANK:KM,KRANK),ZV,ZBETA) ENDIF ! Apply Householder matrix IM = KM-KRANK+1 IN = KN-KRANK+1 ! LAPACK CALL DLARF('Left',IM,IN,ZV,1,ZBETA,PA(KRANK,KRANK),KM,ZWORK) ENDIF ! Update column norms ZTAU = 0.0_JPRD IF(KRANK < IMIN) THEN PA(KRANK+1:KM,KRANK) = ZV(2:IM) DO JN=KRANK+1,KN ZC(JN) = ZC(JN)-PA(KRANK,JN)**2 IF(ZC(JN) > ZTAU) THEN IK = JN ZTAU = ZC(JN) ENDIF ENDDO ! Re-compute column norms due to round-off error IF(ZTAU < ZEPS*ZTAU_REC .OR. ZTAU < 0._JPRD .or. (KN-KRANK) > 100 ) THEN DO JN=KRANK+1,KN ZC(JN) = DOT_PRODUCT(PA(KRANK+1:,JN),PA(KRANK+1:,JN)) IF(ZC(JN) > ZTAU) THEN IK = JN ZTAU = ZC(JN) ENDIF ENDDO !write(0,*) 'RECOMPUTE TAU ',KRANK,ZTAU_REC,ZTAU ZTAU_REC = ZTAU ENDIF ENDIF ENDDO ! Make sure klist is filled also beyond krank DO JN=1,KN KLIST(JN) = JN ENDDO DO JN=1,KRANK ISWAP = KLIST(JN) KLIST(JN) = KLIST(ILIST(JN)) KLIST(ILIST(JN)) = ISWAP ENDDO END SUBROUTINE ALG541 !============================================================================== SUBROUTINE ALG511(PEPS,KSIZE,PX,PV,PBETA) IMPLICIT NONE ! Compute Householder vector ! Algorithm 5.1.1 from Matrix Computations, G.H.Golub & C.F van Loen, third ed. REAL(KIND=JPRD),INTENT(IN) :: PEPS ! Precision REAL(KIND=JPRD),INTENT(IN) :: PX(:) INTEGER(KIND=JPIM), INTENT(IN) :: KSIZE REAL(KIND=JPRD),INTENT(OUT) :: PV(:) REAL(KIND=JPRD),INTENT(OUT) :: PBETA INTEGER(KIND=JPIM) :: IL REAL(KIND=JPRD) :: ZSIGMA,ZMU, ZNORM REAL(KIND=JPRD) :: ZX(KSIZE) !------------------------------------------------------------------------------- ! normalize ZNORM=0._JPRD DO IL=1,KSIZE ZNORM = ZNORM + PX(IL)*PX(IL) ENDDO ZNORM=SQRT(ZNORM) ZX(:)=PX(1:KSIZE) IF( ZNORM > PEPS ) ZX(:)=PX(1:KSIZE)/ZNORM ZSIGMA=0._JPRD IF( KSIZE > 1 ) ZSIGMA = DOT_PRODUCT(ZX(2:KSIZE),ZX(2:KSIZE)) PV(1) = 1.0_JPRD IF( KSIZE > 1 ) PV(2:KSIZE) = ZX(2:KSIZE) IF(ABS(ZSIGMA) < PEPS**2) THEN PBETA = 0.0_JPRD ELSE ZMU = SQRT(ZX(1)**2+ZSIGMA) IF(ZX(1) <= 0.0_JPRD) THEN PV(1) = ZX(1)-ZMU ELSE PV(1) = -ZSIGMA/(ZX(1)+ZMU) ENDIF PBETA = 2.0_JPRD*PV(1)**2/(ZSIGMA+PV(1)**2) PV(:) = PV(:)/(PV(1)) ENDIF END SUBROUTINE ALG511 !================================================================================ END MODULE INTERPOL_DECOMP_MOD ectrans-1.8.0/src/trans/common/internal/supolf_mod.F900000664000175000017500000001627215174631767023045 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE SUPOLF_MOD CONTAINS SUBROUTINE SUPOLF(KM,KNSMAX,DDMU,DDPOL,KCHEAP) !**** *SUPOL * - Routine to compute the Legendre polynomials ! Purpose. ! -------- ! For a given value of mu and M, computes the Legendre ! polynomials upto KNSMAX !** Interface. ! ---------- ! *CALL* *SUPOLF(KM,KNSMAX,DDMU,DDPOL,KCHEAP) ! Explicit arguments : ! -------------------- ! KM : zonal wavenumber M ! KNSMAX : Truncation (triangular) ! DDMU : Abscissa at which the polynomials are computed (mu) ! DDPOL : Polynomials (the first index is m and the second n) ! KCHEAP : odd/even saving switch ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Nils Wedi + George Mozdzynski + Mats Hamrud ! Modifications. ! -------------- ! Original : 87-10-15 ! K. YESSAD (MAY 1998): modification to avoid underflow. ! R. El Khatib 11-Apr-2007 Emulation of vectorized quadruple precision ! on NEC ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM USE TPM_POL ,ONLY : DFI, DFB, DFG, DFA, DFF IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM INTEGER(KIND=JPIM),INTENT(IN) :: KNSMAX REAL(KIND=JPRD) ,INTENT(IN) :: DDMU REAL(KIND=JPRD) ,INTENT(OUT) :: DDPOL(0:KNSMAX) INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL :: KCHEAP REAL(KIND=JPRD) :: DLX, ZCOS_THETA, ZCOS2_THETA, ZCOS_THETA_R, DLK, DL1, DLKM1, DLKM2 INTEGER(KIND=JPIM) :: JN, KKL, ICHEAP, IC REAL(KIND=JPRD) :: DCL, DDL REAL(KIND=JPRD) :: ZFAC, ZLSITA, ZFAC0, ZFAC1, ZMULT, ZEPS INTEGER(KIND=JPIM) :: JCORR, ICORR3, ICORR(KNSMAX), ISTART, IINC REAL(KIND=JPRD) :: ZSCALE, ZISCALE DCL(KKL)=SQRT((REAL(KKL-KM+1,JPRD)*REAL(KKL-KM+2,JPRD)* & & REAL(KKL+KM+1,JPRD)*REAL(KKL+KM+2,JPRD))/(REAL(2*KKL+1,JPRD)*REAL(2*KKL+3,JPRD)*& & REAL(2*KKL+3,JPRD)*REAL(2*KKL+5,JPRD))) DDL(KKL)=(2.0_JPRD*REAL(KKL,JPRD)*REAL(KKL+1,JPRD)-2.0_JPRD*REAL(KM**2,JPRD)-1.0_JPRD)/ & & (REAL(2*KKL-1,JPRD)*REAL(2*KKL+3,JPRD)) ! ------------------------------------------------------------------ !* 1. First two columns. ! ------------------ ZEPS = EPSILON(ZSCALE) ICORR3 = 0 ! This parameter determines which polynomials are computed ! ICHEAP = 1 : all polynomials ! ICHEAP = 2 : only even polynomials ! ICHEAP = 3 : only odd polynomials ICHEAP = 1 IF (PRESENT(KCHEAP)) THEN ICHEAP = KCHEAP ENDIF ! Ordinate to compute polynomials at (i.e. the sine of latitude) DLX = DDMU ! Cosine^2 of latitude ZCOS2_THETA = 1.0_JPRD - DLX * DLX ZCOS_THETA = SQRT(ZCOS2_THETA) !* ordinary Legendre polynomials from series expansion ! --------------------------------------------------- ! This logic is triggered for latitudes very close to the poles, like 89.99999999999999 degrees IF (ABS(ZCOS_THETA) <= ZEPS) THEN DLX = 1.0_JPRD ZCOS_THETA = 0.0_JPRD ZCOS_THETA_R = 0.0_JPRD ZCOS2_THETA = 0.0_JPRD ELSE ZCOS_THETA_R = 1.0_JPRD / ZCOS_THETA ENDIF DLKM2 = 1._JPRD DLKM1 = DLX IF (KM == 0) THEN DDPOL(0) = DLKM2 DDPOL(1) = DLKM1 * DFB(1) / DFA(1) DO JN = 2, KNSMAX DLK = DFF(JN) * DLX * DLKM1 - DFG(JN) * DLKM2 DDPOL(JN) = DLK * DFB(JN) / DFA(JN) DLKM2 = DLKM1 DLKM1 = DLK ENDDO ELSEIF (KM == 1) THEN DDPOL(0) = 0 DDPOL(1) = ZCOS_THETA * DFB(1) DO JN = 2, KNSMAX DLK = DFF(JN) * DLX * DLKM1 - DFG(JN) * DLKM2 DL1 = DFI(JN) * (DLKM1 - DLX * DLK) * ZCOS_THETA_R DDPOL(JN) = DL1 * DFB(JN) DLKM2 = DLKM1 DLKM1 = DLK ENDDO ELSE ! ------------------------------------------------------------------ !* KM >= 2 ! ------------------------------------------------------------------ ZSCALE = 1.0E+100_JPRD ! A very big number ZISCALE = 1.0E-100_JPRD ! A very small number ! Calculate (cos^2(theta))^(m/2) = (1 - mu^2)^(m/2) ! ZLSITA can become absolutely TINY for large KM, so whenever it goes below a threshold, ZISCALE, ! we rescale it by multiplying with ZSCALE and keep track of the number of such rescalings in ! ICORR3 ZLSITA = 1.0_JPRD DO JN = 1, KM / 2 ZLSITA = ZLSITA * ZCOS2_THETA IF (ABS(ZLSITA) < ZISCALE) THEN ZLSITA = ZLSITA * ZSCALE ICORR3 = ICORR3 + 1 ENDIF ENDDO IF (MOD(KM,2) == 1) ZLSITA = ZLSITA * ZCOS_THETA ! Calculate the first factorial term p_0 = sqrt(2m-1) * prod_{n=1}^{m-1} sqrt((2n-1)/(2n)) ZFAC = 1.0_JPRD DO JN = 1, KM - 1 ZFAC = ZFAC * SQRT(REAL(2 * JN - 1, JPRD)) ZFAC = ZFAC / SQRT(REAL(2 * JN, JPRD)) ENDDO ZFAC = ZFAC * SQRT(REAL(2 * KM - 1, JPRD)) ZFAC0 = 1.0_JPRD ! Fill the first 4 values using explicit formulae DO IC = 0, MIN(KNSMAX - KM, 3) ! (2m+i)! ZFAC0 = ZFAC0 * REAL(2 * KM + IC, JPRD) SELECT CASE (IC) CASE (0) ZFAC1 = 1.0_JPRD ! 0! ! d_0 = d_0 ZMULT = ZFAC CASE (1) ZFAC1 = 1.0_JPRD ! 1! ! p_1 = (2m+1) * p_0 ZFAC = ZFAC * REAL(2 * KM + 1, JPRD) ! d_1 = mu * p_1 ZMULT = ZFAC * DLX CASE (2) ZFAC1 = 2.0_JPRD ! 2! ! d_2 = 0.5 * p_2 * ( (2m+3) * mu^2 - 1 ) (p_2 = p_1) ZMULT = 0.5_JPRD * ZFAC * (REAL(2 * KM + 3, JPRD) * DLX * DLX - 1.0_JPRD) CASE (3) ZFAC1 = 6.0_JPRD ! 3! ! p_3 = (2m+3) * p_2 ZFAC = ZFAC * REAL(2 * KM + 3, JPRD) ! d_3 = (1/6) * mu * p_3 * ( (2m+5) * mu^2 - 3 ) ZMULT = (1.0_JPRD / 6.0_JPRD) * DLX * ZFAC * (REAL(2 * KM + 5, JPRD) * DLX * DLX - 3.0_JPRD) END SELECT ! P_{m,m+j} = (1 - mu^2)^{m/2} * d_j * sqrt( (2(m+j)+1) * j! / prod_{j'=0}^{j} (2m+j') ) DDPOL(KM + IC) = ZLSITA * ZMULT * SQRT(2.0_JPRD * (REAL(KM + IC, JPRD) + 0.5_JPRD) * ZFAC1 / ZFAC0) ENDDO ICORR(:) = ICORR3 IF (ICHEAP /= 3) THEN ISTART = 0 ELSE ISTART = 1 ENDIF IF (ICHEAP == 2 .OR. ICHEAP == 3) THEN IINC = 2 ELSE IINC = 1 ENDIF DO JN = KM + ISTART + 4, KNSMAX, IINC IF (ABS(DDPOL(JN-4)) > ZSCALE) THEN DDPOL(JN-4:JN-1) = DDPOL(JN-4:JN-1) / ZSCALE ICORR(JN-4:KNSMAX) = ICORR(JN-4:KNSMAX) - 1 ENDIF ! P_{m,n} = ( (mu^2 - f_1(n-2)) * P_{m,n-2} - f_2(n_4) * P_{m,n-4} ) / f_2(n_2) DDPOL(JN) = ((DLX * DLX - DDL(JN-2)) * DDPOL(JN-2) - DCL(JN-4) * DDPOL(JN-4)) / DCL(JN-2) ENDDO ! Undo all rescalings to get back the true value DO JN = KM + ISTART, KNSMAX, IINC DO JCORR = 1, ICORR(JN) DDPOL(JN) = DDPOL(JN) / ZSCALE IF (DDPOL(JN) < ZEPS) THEN DDPOL(JN) = ZEPS ENDIF ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SUPOLF END MODULE SUPOLF_MOD ectrans-1.8.0/src/trans/common/internal/suwavedi_mod.F900000664000175000017500000001314615174631767023361 0ustar alastairalastair! (C) Copyright 1996- ECMWF. ! (C) Copyright 1996- 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. ! MODULE SUWAVEDI_MOD CONTAINS SUBROUTINE SUWAVEDI(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS,& &KPTRMS,KALLMS,KDIM0G) !**** *SUWAVEDI * - Routine to initialize spectral wave distribution ! Purpose. ! -------- ! Initialize arrays controlling spectral wave distribution !** Interface. ! ---------- ! *CALL* *SUWAVEDI * ! Explicit arguments : ! -------------------- ! KSMAX - Spectral truncation limit (input) ! KTMAX - Overtruncation for KSMAX (input) ! KPRTRW - Number of processors in A-direction (input) ! KMYSETW - A-set for present processor (input) ! KASM0 - Offsets for spectral waves (output) ! KSPOLEGL - Local version of NSPOLEG (output) ! KPROCM - Where a certain spectral wave belongs (output) ! KUMPP - Number of spectral waves on this PE (output) ! KSPEC - Local version on NSPEC (output) ! KSPEC2 - Local version on NSPEC2 (output) ! KSPEC2MX - Maximum KSPEC2 across PEs (output) ! KPOSSP - Global spectral fields partitioning (output) ! KMYMS - This PEs spectral zonal wavenumbers (output) ! KPTRMS - Pointer to the first wave number of a given a-set (output) ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order (output) ! Implicit arguments : NONE ! -------------------- ! Method. ! ------- ! See documentation ! Externals. NONE. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 96-01-10 ! L.Isaksen: 96-02-02 - Calculation of KSPEC2MX added ! K.YESSAD : 97-02-18 - Add KTMAX, bug correction for KSPOLEGL. ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE ! DUMMY INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KTMAX INTEGER(KIND=JPIM),INTENT(IN) :: KPRTRW INTEGER(KIND=JPIM),INTENT(IN) :: KMYSETW INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC2 INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC2MX INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPOLEGL INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KASM0(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPROCM(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KUMPP(KPRTRW) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMYMS(KSMAX+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPOSSP(KPRTRW+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPTRMS(KPRTRW) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KALLMS(KSMAX+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KDIM0G(0:KSMAX) ! LOCAL INTEGER(KIND=JPIM) :: IK, IL, IND, IPOS, ISPEC2P, JA, JM,JMLOC,IM INTEGER(KIND=JPIM) :: ISPOLEGL,ISPEC2MX,IASM0(0:KSMAX),IPROCM(0:KSMAX) INTEGER(KIND=JPIM) :: IUMPP(KPRTRW),IMYMS(KSMAX+1),IPOSSP(KPRTRW+1) INTEGER(KIND=JPIM) :: IPTRMS(KPRTRW),IALLMS(KSMAX+1),IDIM0G(0:KSMAX) INTEGER(KIND=JPIM) :: ISPEC(KPRTRW),IC(KPRTRW) ! ----------------------------------------------------------------- !* 1. Initialize partitioning of wave numbers to PEs ! ---------------------------------------------- ISPEC(:) = 0 IUMPP(:) = 0 IASM0(:) = -99 ISPOLEGL = 0 IL = 1 IND = 1 IK = 0 IPOS = 1 DO JM=0,KSMAX IK = IK + IND IF (IK > KPRTRW) THEN IK = KPRTRW IND = -1 ELSEIF (IK < 1) THEN IK = 1 IND = 1 ENDIF IPROCM(JM) = IK ISPEC(IK) = ISPEC(IK)+KSMAX-JM+1 IUMPP(IK) = IUMPP(IK)+1 IF (IK == KMYSETW) THEN ISPOLEGL = ISPOLEGL +KTMAX+1-JM+1 IMYMS(IL) = JM IASM0(JM) = IPOS IPOS = IPOS+(KSMAX-JM+1)*2 IL = IL+1 ENDIF ENDDO IPOSSP(1) = 1 ISPEC2P = 2*ISPEC(1) ISPEC2MX = ISPEC2P IPTRMS(1) = 1 DO JA=2,KPRTRW IPOSSP(JA) = IPOSSP(JA-1)+ISPEC2P ISPEC2P = 2*ISPEC(JA) ISPEC2MX = MAX(ISPEC2MX,ISPEC2P) ! pointer to the first wave number of a given wave-set in NALLMS array IPTRMS(JA) = IPTRMS(JA-1)+IUMPP(JA-1) ENDDO IPOSSP(KPRTRW+1) = IPOSSP(KPRTRW)+ISPEC2P ! IALLMS : wave numbers for all wave-set concatenated together to give all ! wave numbers in wave-set order. IC(:) = 0 DO JM=0,KSMAX IALLMS(IC(IPROCM(JM))+IPTRMS(IPROCM(JM))) = JM IC(IPROCM(JM)) = IC(IPROCM(JM))+1 ENDDO IPOS = 1 DO JA=1,KPRTRW DO JMLOC=1,IUMPP(JA) IM = IALLMS(IPTRMS(JA)+JMLOC-1) IDIM0G(IM) = IPOS IPOS = IPOS+(KSMAX+1-IM)*2 ENDDO ENDDO IF(PRESENT(KSPEC)) KSPEC = ISPEC(KMYSETW) IF(PRESENT(KSPEC2)) KSPEC2 = 2*ISPEC(KMYSETW) IF(PRESENT(KSPEC2MX)) KSPEC2MX = ISPEC2MX IF(PRESENT(KSPOLEGL)) KSPOLEGL = ISPOLEGL IF(PRESENT(KASM0)) KASM0(:) = IASM0(:) IF(PRESENT(KPROCM)) KPROCM(:) = IPROCM(:) IF(PRESENT(KUMPP)) KUMPP(:) = IUMPP(:) IF(PRESENT(KMYMS)) KMYMS(:) = IMYMS(:) IF(PRESENT(KPOSSP)) KPOSSP(:) = IPOSSP(:) IF(PRESENT(KPTRMS)) KPTRMS(:) = IPTRMS(:) IF(PRESENT(KALLMS)) KALLMS(:) = IALLMS(:) IF(PRESENT(KDIM0G)) KDIM0G(:) = IDIM0G(:) END SUBROUTINE SUWAVEDI END MODULE SUWAVEDI_MOD ectrans-1.8.0/src/trans/common/internal/sugaw_mod.F900000664000175000017500000002755115174631767022665 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE SUGAW_MOD CONTAINS SUBROUTINE SUGAW(KDGL,KM,KN,PL,PW,PANM,PFN) USE EC_PARKIND ,ONLY : JPRD, JPIM USE TPM_CONSTANTS ,ONLY : RA USE TPM_GEN ,ONLY : NOUT USE GAWL_MOD ,ONLY : GAWL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE SUPOLF_MOD ,ONLY : SUPOLF USE TPM_POL ,ONLY : DDI !**** *SUGAW * - Routine to initialize the Gaussian ! abcissa and the associated weights ! Purpose. ! -------- ! Initialize arrays PL, and PW (quadrature abscissas and weights) !** Interface. ! ---------- ! *CALL* *SUGAW(KN,PFN,PL,PW) * ! Explicit arguments : ! -------------------- ! INPUT: ! KDGL : Number of Gauss abscissas ! KM : Polynomial order m ! KN : Polynomial degree n ! PFN : Fourier coefficients of series expansion for ! the ordinary Legendre polynomials ! OUTPUT: ! PL (KN) : abscissas of Gauss ! PW (KN) : Weights of the Gaussian integration ! PL (i) is the abscissa i starting from the northern pole, it is ! the cosine of the colatitude of the corresponding row of the collocation ! grid. ! Implicit arguments : ! -------------------- ! None ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! S.L. Belousov, Tables of normalized associated Legendre Polynomials, Pergamon Press (1962) ! P.N. Swarztrauber, On computing the points and weights for Gauss-Legendre quadrature, ! SIAM J. Sci. Comput. Vol. 24 (3) pp. 945-954 (2002) ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-10-15 ! Michel Rochas : 90-08-30 ! Philippe Courtier : 92-12-19 Multitasking ! Ryad El Khatib : 94-04-20 Remove unused comdecks pardim and yomdim ! Mats Hamrud : 94-08-12 Printing level ! K. Yessad (Sep 2008): cleaning, improve comments. ! Nils Wedi + Mats Hamrud, 2009-02-05 revised following Swarztrauber, 2002 ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KM INTEGER(KIND=JPIM),INTENT(IN) :: KN REAL(KIND=JPRD) ,INTENT(IN) :: PANM REAL(KIND=JPRD),INTENT(OUT) :: PW(KDGL) REAL(KIND=JPRD),INTENT(OUT) :: PL(KDGL) REAL(KIND=JPRD) ,OPTIONAL, INTENT(IN) :: PFN(0:KDGL,0:KDGL) ! ------------------------------------------------------------------ REAL(KIND=JPRD) :: ZLI(KDGL),ZT(KDGL),ZFN(0:KDGL/2),ZL(KDGL) REAL(KIND=JPRD) :: ZREG(KDGL),ZMOD(KDGL),ZM(KDGL),ZRR(KDGL) INTEGER(KIND=JPIM) :: ITER(KDGL) INTEGER(KIND=JPIM) :: IALLOW, INS2, ISYM, JGL, IK, IODD, I, IMAX REAL(KIND=JPRD) :: Z, ZEPS, Z0, ZPI ! computations in extended precision for alternative root finding ! which also works for associated polynomials (m>0) INTEGER, PARAMETER :: JPRH = JPRD REAL(KIND=JPRH) :: ZLK, ZLK1, ZLLDN, ZANM REAL(KIND=JPRH) :: ZTHETA, ZTHETA0, ZX, ZX0, ZDX0, ZH, ZPIH, ZS0 REAL(KIND=JPRH) :: ZK1, ZK2, ZK3, ZK4 REAL(KIND=JPRH) :: ZF1, ZF2, ZF3 REAL(KIND=JPRH) :: FP, FQ, FP1, FQ1 REAL(KIND=JPRH) :: X, ZXOLD, ZBIG, ZEPSH INTEGER(KIND=JPIM) :: ISTEPMAX LOGICAL :: LLP2, LLREF, LLOLD REAL(KIND=JPRD) :: ZDDPOL(0:KN) INTEGER(KIND=JPIM), PARAMETER :: JPKD=KIND(ZLK) FP(X) = 1._JPRH-X**2 FQ(X) = REAL(KN*(KN+1),JPRH)-REAL(KM**2,JPRH)/(1._JPRH-X**2) FP1(X) = -2._JPRH*X FQ1(X) = -2._JPRH*X*REAL(KM**2,JPRH)/SQRT(1._JPRH-X**2) ! ------------------------------------------------------------------ ! ------------------------------------------------------------------ !* 1. Initialization + root + weight computation ! ------------------------------------------ LLP2 = .FALSE. INS2 = KDGL/2 LLOLD=( KM == 0 .AND. KN == KDGL ).AND.PRESENT(PFN) CALL GSTATS(1650,0) ZEPS = EPSILON(Z) ZEPSH = EPSILON(X) ZBIG = SQRT(HUGE(X)) !* 1.1 Find the roots of the ordinary ! Legendre polynomial of degree KN using an analytical first guess ! and then refine to machine precision via Newton's method ! in double precision following Swarztrauber (2002) ! Nils Comment: in principle the else case could also be used for this but ! this is slightly more accurate and consistent with the past IF( LLOLD ) THEN ZPI = 2.0_JPRD*ASIN(1.0_JPRD) IODD=MOD(KDGL,2) IK=IODD DO JGL=IODD,KDGL,2 ZFN(IK)=PFN(KDGL,JGL) IK=IK+1 ENDDO DO JGL=1,INS2 Z = REAL(4*JGL-1,JPRD)*ZPI/REAL(4*KN+2,JPRD) ! analytic initial guess for cos(theta) (same quality as RK below) ! ZX = 1._JPRD-REAL(KN-1,JPRD)/REAL(8*KN*KN*KN,JPRD)-(1._JPRD/REAL(384*KN*KN*KN*KN))*(39._JPRD-28._JPRD/SIN(Z)**2) ! PL(JGL) = ACOS(ZX*COS(Z)) ZL(JGL) = Z+1.0_JPRD/(TAN(Z)*REAL(8*KN**2,JPRD)) ZREG(JGL) = COS(Z) ZLI(JGL) = COS(ZL(JGL)) ENDDO ! refine PL here via Newton's method !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JGL) DO JGL=INS2,1,-1 CALL GAWL(ZFN,ZL(JGL),PW(JGL),ZEPS,KN,ITER(JGL),ZMOD(JGL)) ENDDO !$OMP END PARALLEL DO ! convert to physical latitude space PMU !DIR$ IVDEP !OCL NOVREC DO JGL=1,INS2 PL(JGL) = COS(ZL(JGL)) ENDDO ELSE !* 1.2 Find the roots of the associated ! Legendre polynomial of degree KN and the associated Gaussian weights ! using a Runge-Kutta 4 integration of the Pruefer transformed Sturm-Liouville problem ! (Tygert (J. Comput. Phys. 2008) and Glaser et al., SIAM J. SCI. COMPUT. Vol. 29 (4) 1420-1438) ! ISTEPMAX=10 ZANM = REAL(PANM, JPKD) ZPIH = 2.0_JPRH*ASIN(1.0_JPRH) ZX0 = 0._JPRH Z0 = 0._JPRD ! first guess starting point IF( MOD(KN-KM,2) == 0 ) THEN ! even, extremum at X == 0 ZTHETA0 = 0._JPRH ZH = -0.5_JPRH*ZPIH/REAL(ISTEPMAX,JPRH) ELSE ! odd, root at X == 0 ZTHETA0 = 0.5_JPRH*ZPIH ZX0 = 0._JPRH ZH = -ZPIH/REAL(ISTEPMAX,JPRH) ENDIF ZX = ZX0 ZTHETA = ZTHETA0 ZF1 = SQRT(FQ(ZX)/FP(ZX)) ZF2 = FQ1(ZX)/FQ(ZX) ZF3 = FP1(ZX)/FP(ZX) ! Formula (81) in Tygert ZDX0=-1._JPRH/(ZF1 + 0.25_JPRH*(ZF2 + ZF3)*SIN(2._JPRH*ZTHETA)) ! loop over all roots LLREF=.TRUE. DO JGL=INS2,1,-1 ! runge-kutta DGL:DO IK=1,ISTEPMAX ZK1 = ZDX0 ZTHETA = ZTHETA + 0.5_JPRH*ZH ZX = ZX0 + 0.5_JPRH*ZH*ZK1 ZF1 = SQRT(FQ(ZX)/FP(ZX)) ZF2 = FQ1(ZX)/FQ(ZX) ZF3 = FP1(ZX)/FP(ZX) ZK2 = -1._JPRH/(ZF1 + 0.25_JPRH*(ZF2 + ZF3)*SIN(2._JPRH*ZTHETA)) ZX = ZX0 + 0.5_JPRH*ZH*ZK2 ZF1 = SQRT(FQ(ZX)/FP(ZX)) ZF2 = FQ1(ZX)/FQ(ZX) ZF3 = FP1(ZX)/FP(ZX) ZK3 = -1._JPRH/(ZF1 + 0.25_JPRH*(ZF2 + ZF3)*SIN(2._JPRH*ZTHETA)) ZTHETA = ZTHETA + 0.5_JPRH*ZH ZX = ZX0 + ZH*ZK3 ZF1 = SQRT(FQ(ZX)/FP(ZX)) ZF2 = FQ1(ZX)/FQ(ZX) ZF3 = FP1(ZX)/FP(ZX) ZK4 = -1._JPRH/(ZF1 + 0.25_JPRH*(ZF2 + ZF3)*SIN(2._JPRH*ZTHETA)) ZX = ZX0 + (1._JPRH/6._JPRH)*ZH*(ZK1+2._JPRH*ZK2+2._JPRH*ZK3+ZK4) ZXOLD = ZX0 ZX0 = ZX IF( .NOT.ZX==ZX ) THEN WRITE(NOUT,*) 'invoke overflow ...ZX ',KM, KN, JGL ZX = ZXOLD ZX0 = ZXOLD EXIT DGL ENDIF ZF1 = SQRT(FQ(ZX)/FP(ZX)) ZF2 = FQ1(ZX)/FQ(ZX) ZF3 = FP1(ZX)/FP(ZX) ZDX0 = -1._JPRH/(ZF1 + 0.25_JPRH*(ZF2 + ZF3)*SIN(2._JPRH*ZTHETA)) ENDDO DGL ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Everything from here until <> is to refine the ! root and compute the starting point for the next root search ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! should not happen, but does if loss of accuracy in supolf occurs (useful for debugging) IF( JGL < INS2 ) LLREF = PW(JGL+1) > ZEPSH IF( LLREF ) THEN ! chosen for speed/accuracy compromise IMAX=3 LOOP: DO I=1,IMAX ! supol fast ZS0 = ACOS(ZX0) CALL SUPOLF(KM,KN,REAL(ZX0,JPRD),ZDDPOL) ZLK=REAL(ZDDPOL(KN),JPKD) ZLK1= REAL(ZDDPOL(KN-1),JPKD) ZLLDN= -(ZANM*ZLK1-DDI(KN)*COS(ZS0)*ZLK)/SIN(ZS0) IF( ABS(ZLLDN) > ZEPSH ) THEN ! single Newton refinement in theta ZS0 = ZS0 - ZLK/ZLLDN ZX = COS(ZS0) ELSE ! do nothing ZX = ZX0 ENDIF IF( ABS(ZX-ZX0) > 1000._JPRD*ZEPS ) THEN ZX0 = ZX ELSE EXIT LOOP ENDIF ENDDO LOOP ! recompute for accuracy weights CALL SUPOLF(KM,KN,REAL(ZX,JPRD),ZDDPOL) ! option f in Schwarztrauber to compute the weights ZS0 = ACOS(ZX) ZLK=REAL(ZDDPOL(KN),JPKD) ZLK1= REAL(ZDDPOL(KN-1),JPKD) ZLLDN= -(ZANM*ZLK1-DDI(KN)*COS(ZS0)*ZLK)/SIN(ZS0) PW(JGL) = REAL(REAL(2*KN+1,JPRH)/ZLLDN**2,JPRD) ! catch overflow, should never happen IF( .NOT.(PW(JGL)==PW(JGL)) ) THEN WRITE(NOUT,*) 'invoke overflow ...PW ',KM, KN, JGL PW(JGL) = 0.0_JPRD ENDIF ELSE ! should never happen ... WRITE(NOUT,*) 'Refinement not possible ... PW set to 0',KM, KN, JGL PW(JGL) = 0.0_JPRD ENDIF ZX0 = ZX PL(JGL) = REAL(ZX0,JPRD) ! catch overflow, should never happen IF( .NOT.(PW(JGL)==PW(JGL)) ) THEN WRITE(NOUT,*) 'invoke overflow ...PW ',KM, KN, JGL PW(JGL) = 0.0_JPRD ENDIF ! ++++++++++++++++++++++++++++++++++++++++++++++++ ! <<<< END REFINEMENT >>>> ! ++++++++++++++++++++++++++++++++++++++++++++++++ ZF1 = SQRT(FQ(ZX0)/FP(ZX0)) ZF2 = FQ1(ZX0)/FQ(ZX0) ZF3 = FP1(ZX0)/FP(ZX0) ! continue to next root with refined ZX,ZR as initial condition ZH = -ZPIH/REAL(ISTEPMAX,JPRH) ZTHETA = 0.5_JPRH*ZPIH ZDX0 = -1._JPRH/(ZF1 + 0.25_JPRH*(ZF2 + ZF3)*SIN(2._JPRH*ZTHETA)) ENDDO ENDIF CALL GSTATS(1650,1) ! ------------------------------------------------------------------ !DIR$ IVDEP !OCL NOVREC DO JGL=1,KDGL/2 ISYM = KDGL-JGL+1 PL(ISYM) = -PL(JGL) PW(ISYM) = PW(JGL) ENDDO ! ------------------------------------------------------------------ !* 3. Diagnostics. ! ------------ IF( LLOLD ) THEN IF(LLP2)THEN DO JGL=1,INS2 ZM(JGL) = (ACOS(PL(JGL))-ACOS(ZLI(JGL)))*RA ZRR(JGL) = (ACOS(PL(JGL))-ACOS(ZREG(JGL)))*RA ZT(JGL) = ACOS(PL(JGL))*180._JPRD/ZPI ENDDO ENDIF IALLOW = 20 DO JGL=1,INS2 IF(LLP2)THEN WRITE(UNIT=NOUT,FMT=& &'('' M ='',I4,'' ROW ='',I4,'' ITERATIONS='',I4,'' ROOT='',F30.20,& &'' WEIGHT='',F30.20,'' MODIF :'',E9.2)')KM,JGL,ITER(JGL),PL(JGL)& &,PW(JGL),PL(JGL)-ZLI(JGL) WRITE(UNIT=NOUT,FMT=& &'(10X,'' LAST INC. : '',E9.2,'' MODIF IN M : '',F10.3,& &'' FROM THE REGULAR GRID : '',F10.3,'' COLAT '',F10.3)')& &ZMOD(JGL),ZM(JGL),ZRR(JGL),ZT(JGL) ENDIF IF(ITER(JGL) > IALLOW)THEN WRITE(UNIT=NOUT,FMT='('' CONVERGENCE FAILED IN SUGAW '')') WRITE(UNIT=NOUT,FMT='('' ALLOWED : '',I4,''& &NECESSARY : '',& &I4)')IALLOW,ITER(JGL) CALL ABORT_TRANS(' FAILURE IN SUGAW ') ENDIF ENDDO ELSE IF(LLP2)THEN DO JGL=1,INS2 WRITE(UNIT=NOUT,FMT=& &'('' M ='',I4,'' ROW ='',I4,'' ITERATIONS='',I4,'' ROOT='',F30.20,& &'' WEIGHT='',F30.20,'' COLAT '',F10.3)')KM,JGL,0,PL(JGL),PW(JGL),& & ACOS(PL(JGL))*180._JPRD/ZPIH ENDDO ENDIF ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SUGAW END MODULE SUGAW_MOD ectrans-1.8.0/src/trans/common/internal/tpm_dim.F900000775000175000017500000000325715174631767022331 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TPM_DIM ! Module for dimensions. USE EC_PARKIND, ONLY: JPIM IMPLICIT NONE SAVE TYPE DIM_TYPE ! SPECTRAL SPACE DIMENSIONS INTEGER(KIND=JPIM) :: NSMAX ! Truncation order INTEGER(KIND=JPIM) :: NTMAX ! Truncation order for tendencies INTEGER(KIND=JPIM) :: NSPOLEG ! Number of Legandre polynomials INTEGER(KIND=JPIM) :: NSPEC_G ! Number of complex spectral coefficients (global) INTEGER(KIND=JPIM) :: NSPEC2_G ! 2*NSPEC_G ! COLLOCATION GRID DIMENSIONS INTEGER(KIND=JPIM) :: NDGL ! Number of rows of latitudes INTEGER(KIND=JPIM) :: NDLON ! Maximum number of longitude points (near equator) INTEGER(KIND=JPIM) :: NDGNH ! Number of rows in northern hemisphere ! Legendre transform dimensions INTEGER(KIND=JPIM) :: NLEI1 ! R%NSMAX+4+MOD(R%NSMAX+4+1,2) INTEGER(KIND=JPIM) :: NLEI3 ! R%NDGNH+MOD(R%NDGNH+2,2) INTEGER(KIND=JPIM) :: NLED3 ! R%NTMAX+2+MOD(R%NTMAX+3,2) INTEGER(KIND=JPIM) :: NLED4 ! R%NTMAX+3+MOD(R%NTMAX+4,2) ! Width of E'-zone INTEGER(KIND=JPIM) :: NNOEXTZL ! Longitude direction INTEGER(KIND=JPIM) :: NNOEXTZG ! Latitude direction END TYPE DIM_TYPE TYPE(DIM_TYPE),ALLOCATABLE,TARGET :: DIM_RESOL(:) TYPE(DIM_TYPE),POINTER :: R END MODULE TPM_DIM ectrans-1.8.0/src/trans/common/internal/sumplatf_mod.F900000664000175000017500000001036715174631767023367 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE SUMPLATF_MOD CONTAINS SUBROUTINE SUMPLATF(KDGL,KPROCA,KMYSETA,& &KULTPP,KPROCL,KPTRLS) !**** *SUMPLATF * - Initialize fourier space distibution in N-S direction ! Purpose. ! -------- !** Interface. ! ---------- ! *CALL* *SUMPLATF * ! Explicit arguments - input : ! -------------------- ! KDGL -last latitude ! KPROCA -number of processors in A direction ! KMYSETA -process number in A direction ! Explicit arguments - output: ! -------------------- ! KULTPP -number of latitudes in process ! (in Fourier space) ! KPROCL -process responsible for latitude ! (in Fourier space) ! KPTRLS -pointer to first global latitude ! of process (in Fourier space) ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. SUMPLATB and SUEMPLATB. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! David Dent:97-06-02 parameters KFRSTLAT etc added ! JF. Estrade:97-11-13 Adaptation to ALADIN case ! J.Boutahar: 98-07-06 phasing with CY19 ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option + cleanings ! (correct computation of extrapolar latitudes for KPROCL). ! Modified 98-12-07 by K. YESSAD and C. FISCHER: cleaning. ! - merge old sumplat.F and suemplat.F ! - gather 'lelam' code and 'not lelam' code. ! - clean (useless duplication of variables, non doctor features). ! - remodularise according to lelam/not lelam ! -> lelam features in new routine suemplatb.F, ! not lelam features in new routine sumplatb.F ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE TPM_GEOMETRY ,ONLY : G USE SUMPLATB_MOD ,ONLY : SUMPLATB ! IMPLICIT NONE ! * DUMMY: INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA INTEGER(KIND=JPIM),INTENT(IN) :: KMYSETA INTEGER(KIND=JPIM),INTENT(OUT) :: KULTPP(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPROCL(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRLS(:) ! * LOCAL: INTEGER(KIND=JPIM) :: INDIC(KPROCA),ILAST(KPROCA) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IA, ILAT, ISTART, IMEDIAP,IRESTM, JA, JLTLOC LOGICAL :: LLSPLIT,LLFOURIER ! ----------------------------------------------------------------- !* 1. CODE DEPENDING ON 'LELAM': COMPUTATION OF ! KMEDIAP, KRESTM, INDIC, ILAST. ! ----------------------------------------- LLSPLIT = .FALSE. LLFOURIER = .TRUE. CALL SUMPLATB(1,KDGL,KPROCA,G%NLOEN,LLSPLIT,LLFOURIER,& &IMEDIAP,IRESTM,INDIC,ILAST) ! ----------------------------------------------------------------- !* 2. CODE NOT DEPENDING ON 'LELAM': ! ------------------------------ ! * Definitions related to distribution of latitudes along sets ! ------------ in fourier-space ----------------------------- ISTART = 0 KULTPP(1) = ILAST(1) DO JA=1,KPROCA IF(JA > 1) THEN IF(ILAST(JA) /= 0) THEN KULTPP(JA) = ILAST(JA)-ILAST(JA-1) ELSE KULTPP(JA) = 0 ENDIF ENDIF DO JLTLOC=1,KULTPP(JA) ILAT = ISTART + JLTLOC KPROCL(ILAT) = JA ENDDO ISTART = ISTART + KULTPP(JA) ENDDO ! * Computes KPTRLS. IA = KPROCL(1) KPTRLS(IA) = 1 DO JA=IA+1,KPROCA KPTRLS(JA) = KPTRLS(JA-1) + KULTPP(JA-1) ENDDO END SUBROUTINE SUMPLATF END MODULE SUMPLATF_MOD ectrans-1.8.0/src/trans/common/internal/tpm_geometry.F900000664000175000017500000000243615174631767023406 0ustar alastairalastair! (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. ! MODULE TPM_GEOMETRY ! Module containing data describing Gaussian grid. USE EC_PARKIND ,ONLY : JPIM ,JPRD IMPLICIT NONE SAVE TYPE GEOM_TYPE INTEGER(KIND=JPIM),ALLOCATABLE :: NLOEN(:) ! NUMBER OF POINTS ON A PARALLEL INTEGER(KIND=JPIM),ALLOCATABLE :: NMEN(:) ! ASSOCIATED CUT-OFF WAVE NUMBER INTEGER(KIND=JPIM),ALLOCATABLE :: NDGLU(:) ! NUMBER OF HEMISPERIC LATITUDES ! FOR A GIVEN WAVE NUMBER M LOGICAL :: LAM ! LAM geometry if T, Global geometry if F LOGICAL :: LREDUCED_GRID ! Reduced Gaussian grid if T ! quadratic Gaussian grid otherwise. REAL(KIND=JPRD) :: RSTRET ! Stretching factor (for Legendre polynomials ! computed on stretched latitudes only) END TYPE GEOM_TYPE TYPE(GEOM_TYPE),ALLOCATABLE,TARGET :: GEOM_RESOL(:) TYPE(GEOM_TYPE),POINTER :: G END MODULE TPM_GEOMETRY ectrans-1.8.0/src/trans/common/internal/shuffle_mod.F900000775000175000017500000000742115174631767023170 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE SHUFFLE_MOD CONTAINS SUBROUTINE SHUFFLE(KF_UV_G,KF_SCALARS_G,KSHFUV_G,KIVSETUV,KSHFSC_G,KIVSETSC,& & KVSETUV,KVSETSC) !**** *SHUFFLE* - Re-shuffle fields for load balancing ! Purpose. ! -------- ! Re-shuffle fields for load balancing if NPRTRV>1. Note that the ! relative order of the local spectral fields has to maintained. !** Interface. ! ---------- ! CALL SHUFFLE(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KSHFUV_G - reshuffling index for uv fields ! KIVSETUV - reshuffled KVSETUV ! KSHFSC_G - reshuffling index for scalar fields ! KIVSETSC - reshuffled KVSETSC ! 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. ! Externals. NONE ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY: JPIM USE TPM_DISTR, ONLY: NPRTRV ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G,KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(OUT) :: KSHFUV_G(:),KSHFSC_G(:) INTEGER(KIND=JPIM), INTENT(OUT) :: KIVSETUV(:),KIVSETSC(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) INTEGER(KIND=JPIM) :: IHELP(MAX(KF_UV_G,KF_SCALARS_G),NPRTRV),IHELPC(NPRTRV) INTEGER(KIND=JPIM) :: IDW,J ! ------------------------------------------------------------------ IF(NPRTRV > 1) THEN IHELP(:,:) = 0 IHELPC(:) = 0 DO J=1,KF_UV_G IHELPC(KVSETUV(J)) = IHELPC(KVSETUV(J))+1 IHELP(IHELPC(KVSETUV(J)),KVSETUV(J)) = J ENDDO IDW = KF_UV_G+1 DO DO J=NPRTRV,1,-1 IF(IHELPC(J) > 0) THEN IDW = IDW-1 KSHFUV_G(IDW) = IHELP(IHELPC(J),J) IHELPC(J) =IHELPC(J)-1 ENDIF ENDDO IF(IDW == 1) EXIT ENDDO IHELP(:,:) = 0 IHELPC(:) = 0 DO J=1,KF_SCALARS_G IHELPC(KVSETSC(J)) = IHELPC(KVSETSC(J))+1 IHELP(IHELPC(KVSETSC(J)),KVSETSC(J)) = J ENDDO IDW = KF_SCALARS_G+1 DO DO J=NPRTRV,1,-1 IF(IHELPC(J) > 0) THEN IDW = IDW-1 KSHFSC_G(IDW) = IHELP(IHELPC(J),J) IHELPC(J) =IHELPC(J)-1 ENDIF ENDDO IF(IDW == 1) EXIT ENDDO DO J=1,KF_UV_G KIVSETUV(J) = KVSETUV(KSHFUV_G(J)) ENDDO DO J=1,KF_SCALARS_G KIVSETSC(J) = KVSETSC(KSHFSC_G(J)) ENDDO ELSE DO J=1,KF_UV_G KSHFUV_G(J) = J KIVSETUV(J) = 1 ENDDO DO J=1,KF_SCALARS_G KSHFSC_G(J) = J KIVSETSC(J) = 1 ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SHUFFLE END MODULE SHUFFLE_MOD ectrans-1.8.0/src/trans/common/internal/sumplatb_mod.F900000664000175000017500000001271015174631767023355 0ustar alastairalastair! (C) Copyright 1998- ECMWF. ! (C) Copyright 1998- 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. ! MODULE SUMPLATB_MOD CONTAINS SUBROUTINE SUMPLATB(KDGSA,KDGL,KPROCA,KLOENG,LDSPLIT,LDFOURIER,& &KMEDIAP,KRESTM,KINDIC,KLAST) !**** *SUMPLATB * - Routine to initialize parallel environment ! Purpose. ! -------- !** Interface. ! ---------- ! *CALL* *SUMPLATB * ! Explicit arguments - input : ! -------------------- ! KDGSA -first latitude (grid-space) ! (may be different from NDGSAG) ! KDGL -last latitude ! KPROCA -number of processors in A direction ! KLOENG -actual number of longitudes per latitude. ! LDSPLIT -true for latitudes shared between sets ! LDFOURIER -true for fourier space partitioning ! Explicit arguments - output: ! -------------------- ! KMEDIAP -mean number of grid points per PE ! KRESTM -number of PEs with one extra point ! KINDIC -intermediate quantity for 'sumplat' ! KLAST -intermediate quantity for 'sumplat' ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. NONE. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! K. YESSAD (after old version of sumplat.F). ! Modifications. ! -------------- ! Original : 98-12-07 ! G. Mozdzynski (August 2012): rewrite of fourier latitude distribution ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM, JPIB, JPRD IMPLICIT NONE ! * DUMMY: INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA INTEGER(KIND=JPIM),INTENT(IN) :: KLOENG(KDGSA:KDGL) LOGICAL,INTENT(IN) :: LDSPLIT LOGICAL,INTENT(IN) :: LDFOURIER INTEGER(KIND=JPIM),INTENT(OUT) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(OUT) :: KRESTM INTEGER(KIND=JPIM),INTENT(OUT) :: KINDIC(KPROCA) INTEGER(KIND=JPIM),INTENT(OUT) :: KLAST(KPROCA) ! * LOCAL: INTEGER(KIND=JPIB) :: ICOST(KDGSA:KDGL) INTEGER(KIND=JPIM) :: ILATS(KPROCA) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: ICOMP, IGL, JA, JGL, ILAST, IREST, IA INTEGER(KIND=JPIM) :: ITOT_TOP, ITOT_BOT, IGL_TOP, IGL_BOT INTEGER(KIND=JPIB) :: IMEDIA,ITOT !REAL(KIND=JPRD) :: ZLG LOGICAL :: LLDONE,LLSIMPLE ! ----------------------------------------------------------------- !* 1. COMPUTATION OF KMEDIAP, KRESTM, KINDIC, KLAST. ! ---------------------------------------------- ! * Computation of KMEDIAP and KRESTM. IF( LDFOURIER )THEN ! DO JGL=1,KDGL ! ZLG=LOG(REAL(KLOENG(JGL),JPRD)) ! ICOST(JGL)=KLOENG(JGL)*ZLG*SQRT(ZLG) ! ENDDO DO JGL=1,KDGL ICOST(JGL)=KLOENG(JGL) ENDDO ELSE DO JGL=1,KDGL ICOST(JGL)=KLOENG(JGL) ENDDO ENDIF IMEDIA = SUM(ICOST(KDGSA:KDGL)) KMEDIAP = IMEDIA / KPROCA KRESTM = IMEDIA - KMEDIAP * KPROCA IF (KRESTM > 0) KMEDIAP = KMEDIAP + 1 ! * Computation of intermediate quantities KINDIC and KLAST KINDIC(:)=0 KLAST(:)=0 IF (LDSPLIT) THEN IREST = 0 ILAST =0 DO JA=1,KPROCA IF (JA <= KRESTM .OR. KRESTM == 0) THEN ICOMP = KMEDIAP ELSE ICOMP = KMEDIAP - 1 ENDIF ITOT = IREST IGL = ILAST+1 DO JGL=IGL,KDGL ILAST = JGL IF(ITOT+ICOST(JGL) < ICOMP) THEN ITOT = ITOT+ICOST(JGL) ELSEIF(ITOT+ICOST(JGL) == ICOMP) THEN IREST = 0 KLAST(JA) = JGL KINDIC(JA) = 0 EXIT ELSE IREST = ICOST(JGL) -(ICOMP-ITOT) KLAST(JA) = JGL KINDIC(JA) = JGL EXIT ENDIF ENDDO ENDDO ELSE ITOT_TOP=0 ITOT_BOT=0 IGL_TOP=1 IGL_BOT=KDGL DO JA=1,(KPROCA-1)/2+1 IF( JA /= KPROCA/2+1 )THEN LLDONE=.TRUE. DO WHILE ( LLDONE ) IF( ITOT_TOP+ICOST(IGL_TOP) < KMEDIAP )THEN KLAST(JA)=IGL_TOP ITOT_TOP=ITOT_TOP+ICOST(IGL_TOP) IGL_TOP=IGL_TOP+1 ELSE ITOT_TOP=ITOT_TOP-KMEDIAP LLDONE=.FALSE. ENDIF ENDDO KLAST(KPROCA-JA+1)=IGL_BOT LLDONE=.TRUE. DO WHILE ( LLDONE ) IF( ITOT_BOT+ICOST(IGL_BOT) < KMEDIAP )THEN ITOT_BOT=ITOT_BOT+ICOST(IGL_BOT) IGL_BOT=IGL_BOT-1 ELSE ITOT_BOT=ITOT_BOT-KMEDIAP LLDONE=.FALSE. ENDIF ENDDO ELSE KLAST(JA)=IGL_BOT ENDIF ENDDO LLSIMPLE=.FALSE. DO JA=1,KPROCA IF( KLAST(JA)==0 )THEN LLSIMPLE=.TRUE. EXIT ENDIF ENDDO IF( LLSIMPLE )THEN ! WRITE(0,'("SUMPLATB_MOD: REVERTING TO SIMPLE LATITUDE DISTRIBUTION")') ILATS(:)=0 IA=0 DO JGL=1,KDGL IA=IA+1 ILATS(IA)=ILATS(IA)+1 IF( IA==KPROCA ) IA=0 ENDDO KLAST(1)=ILATS(1) DO JA=2,KPROCA KLAST(JA)=KLAST(JA-1)+ILATS(JA) ENDDO ENDIF ENDIF END SUBROUTINE SUMPLATB END MODULE SUMPLATB_MOD ectrans-1.8.0/src/trans/common/internal/set2pe_mod.F900000664000175000017500000000761515174631767022740 0ustar alastairalastair! (C) Copyright 1998- ECMWF. ! (C) Copyright 1998- 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. ! MODULE SET2PE_MOD CONTAINS SUBROUTINE SET2PE(KPE,KPRGPNS,KPRGPEW,KPRTRW,KPRTRV) !**** *SET2PE* - Convert from set numbers to PE number ! Purpose. ! -------- ! Convert from set numbers in either grid-point space or spectral space ! to PE number !** Interface. ! ---------- ! *CALL* *SET2PE(KPRGPNS,KPRGPEW,KPRTRW,KPRTRV,KPE) ! Explicit arguments : ! -------------------- ! input : KPRGPNS - integer A set number in grid space ! in the range 1 .. NPRGPNS ! KPRGPEW - integer B set number in grid space ! in the range 1 .. NPRGPEW ! KPRTRW - integer A set number in spectral space ! in the range 1 .. NPRTRW ! KPRTRV - integer B set number in spectral space ! in the range 1 .. NPRTRV ! output: KPE - integer processor number ! in the range 1 .. NPROC ! Normally, one pair of input set numbers will be set to zero ! SET2PE will compute KPE from the first pair if they are valid numbers. ! else from the other pair, ! Implicit arguments : YOMMP parameters ! NPRGPNS,NPRGPEW,NPRTRW,NPRTRV,NPROC ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! NONE ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! David Dent *ECMWF* ! Modifications. ! -------------- ! Original : 98-08-19 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE TPM_DISTR ,ONLY : LEQ_REGIONS, NPRGPEW, NPRGPNS, NPRTRV, NPRTRW USE EQ_REGIONS_MOD ,ONLY : N_REGIONS, N_REGIONS_NS USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KPRGPNS,KPRGPEW,KPRTRW,KPRTRV INTEGER(KIND=JPIM),INTENT(OUT) :: KPE INTEGER(KIND=JPIM) :: JA ! ------------------------------------------------------------------ !* 1. Choose from input parameters ! ---------------------------- IF(KPRGPNS > 0.AND.KPRGPEW > 0) THEN IF( LEQ_REGIONS )THEN IF( KPRGPNS > N_REGIONS_NS )THEN WRITE(*,'(A,2I8)') ' SET2PE INVALID ARGUMENT ',KPRGPNS,N_REGIONS_NS CALL ABOR1(' SET2PE INVALID ARGUMENT ') ENDIF IF( KPRGPEW > N_REGIONS(KPRGPNS) )THEN WRITE(*,'(A,2I8)') ' SET2PE INVALID ARGUMENT ',KPRGPEW,N_REGIONS(KPRGPNS) CALL ABOR1(' SET2PE INVALID ARGUMENT ') ENDIF KPE=0 DO JA=1,KPRGPNS-1 KPE=KPE+N_REGIONS(JA) ENDDO KPE=KPE+KPRGPEW ELSE IF(KPRGPNS <= NPRGPNS.AND.KPRGPEW <= NPRGPEW) THEN !* 2. Grid-space set values supplied ! ------------------------------ KPE=(KPRGPNS-1)*NPRGPEW + KPRGPEW ELSE WRITE(*,'(A,2I8)') ' SET2PE INVALID ARGUMENT ',KPRGPNS,KPRGPEW CALL ABORT_TRANS(' SET2PE INVALID ARGUMENT ') ENDIF ENDIF ELSE !* 3. Spectral space set values supplied ! ---------------------------------- IF(KPRTRW <= NPRTRW.AND.KPRTRV <= NPRTRV) THEN KPE=(KPRTRW-1)*NPRTRV + KPRTRV ELSE WRITE(*,'(A,2I8)') ' SET2PE INVALID ARGUMENT ',KPRTRW,KPRTRV CALL ABORT_TRANS(' SET2PE INVALID ARGUMENT ') ENDIF ENDIF END SUBROUTINE SET2PE END MODULE SET2PE_MOD ectrans-1.8.0/src/trans/common/internal/abort_trans_mod.F900000664000175000017500000000173015174631767024044 0ustar alastairalastair! (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. ! MODULE ABORT_TRANS_MOD CONTAINS SUBROUTINE ABORT_TRANS(CDTEXT) USE TPM_GEN , ONLY : NOUT,NERR USE MPL_MODULE, ONLY : MPL_ABORT, MPL_RANK, MPL_NUMPROC USE SDL_MOD, ONLY : SDL_TRACEBACK, SDL_SRLABORT IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: CDTEXT WRITE(NOUT,'(1X,A)') 'ABORT_TRANS CALLED' WRITE(NOUT,'(1X,A)') CDTEXT WRITE(NERR,'(1X,A,1X,I3,1X,A)') 'ABORT! ',MPL_RANK,CDTEXT CLOSE(NOUT) IF (MPL_NUMPROC > 1) THEN CALL MPL_ABORT(CDTEXT) ELSE CALL SDL_TRACEBACK FLUSH(0) CALL SDL_SRLABORT ENDIF END SUBROUTINE ABORT_TRANS END MODULE ABORT_TRANS_MOD ectrans-1.8.0/src/trans/common/internal/tpm_ctl.F900000775000175000017500000000146215174631767022336 0ustar alastairalastair! (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. ! MODULE TPM_CTL USE SHAREDMEM_MOD, ONLY: SHAREDMEM IMPLICIT NONE SAVE TYPE CTL_TYPE LOGICAL :: LREAD_LEGPOL = .FALSE. LOGICAL :: LWRITE_LEGPOL = .FALSE. CHARACTER(LEN=256) :: CLEGPOLFNAME='legpol_file' CHARACTER(LEN=4) :: CIO_TYPE='file' TYPE(SHAREDMEM) :: STORAGE END TYPE CTL_TYPE TYPE(CTL_TYPE),ALLOCATABLE,TARGET :: CTL_RESOL(:) TYPE(CTL_TYPE),POINTER :: C END MODULE TPM_CTL ectrans-1.8.0/src/trans/common/internal/setup_geom_mod.F900000664000175000017500000000645415174631767023705 0ustar alastairalastair! (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. ! MODULE SETUP_GEOM_MOD CONTAINS SUBROUTINE SETUP_GEOM USE EC_PARKIND ,ONLY : JPRD, JPIM USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPM_FIELDS ,ONLY : F USE TPM_GEOMETRY ,ONLY : G ! IMPLICIT NONE REAL(KIND=JPRD) :: ZSQM2(R%NDGL) INTEGER(KIND=JPIM) :: IDGLU(0:R%NSMAX,R%NDGNH) INTEGER(KIND=JPIM) :: JGL,JM,NSMAXLIN LOGICAL :: LLP1,LLP2 ! ------------------------------------------------------------------ IF(.NOT.D%LGRIDONLY) THEN LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SETUP_GEOM ===' ALLOCATE (G%NMEN(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'G%NMEN ',SIZE(G%NMEN ),SHAPE(G%NMEN ) NSMAXLIN = R%NDGL-1 IF (R%NSMAX>=NSMAXLIN .OR. .NOT. G%LREDUCED_GRID) THEN ! linear or full grid DO JGL=1,R%NDGL G%NMEN(JGL) = MIN(R%NSMAX,(G%NLOEN(JGL)-1)/2) ENDDO ELSEIF (R%NSMAX>=R%NDGL*2/3-1) THEN ! quadratic grid ZSQM2(:) = 3*(NSMAXLIN-R%NSMAX)/R%NDGL*F%R1MU2(:) G%NMEN(1) = MIN(R%NSMAX,INT(REAL(G%NLOEN(1)-1,JPRD)/(2.0_JPRD+ZSQM2(1)))) DO JGL=2,R%NDGNH G%NMEN(JGL) = MIN(R%NSMAX,MAX(G%NMEN(JGL-1),& &INT(REAL(G%NLOEN(JGL)-1,JPRD)/(2.0_JPRD+ ZSQM2(JGL))))) ENDDO ! * SOUTHERN HEMISPHERE : G%NMEN(R%NDGL) = MIN(R%NSMAX,INT(REAL(G%NLOEN(R%NDGL)-1,JPRD)/(2.0_JPRD+ZSQM2(R%NDGL)))) DO JGL=R%NDGL-1, R%NDGNH+1, -1 G%NMEN(JGL) = MIN(R%NSMAX,MAX(G%NMEN(JGL+1),& &INT(REAL(G%NLOEN(JGL)-1,JPRD)/(2.0_JPRD+ ZSQM2(JGL))))) ENDDO ELSE ! cubic grid ZSQM2(:) = F%R1MU2(:) G%NMEN(1) = MIN(R%NSMAX,INT(REAL(G%NLOEN(1)-1,JPRD)/(2.0_JPRD+ZSQM2(1)))-1) DO JGL=2,R%NDGNH G%NMEN(JGL) = MIN(R%NSMAX,MAX(G%NMEN(JGL-1),& &INT(REAL(G%NLOEN(JGL)-1,JPRD)/(2.0_JPRD+ ZSQM2(JGL)))-1)) ENDDO ! * SOUTHERN HEMISPHERE : G%NMEN(R%NDGL) = MIN(R%NSMAX,INT(REAL(G%NLOEN(R%NDGL)-1,JPRD)/(2.0_JPRD+ZSQM2(R%NDGL)))-1) DO JGL=R%NDGL-1, R%NDGNH+1, -1 G%NMEN(JGL) = MIN(R%NSMAX,MAX(G%NMEN(JGL+1),& &INT(REAL(G%NLOEN(JGL)-1,JPRD)/(2.0_JPRD+ ZSQM2(JGL)))-1)) ENDDO ENDIF IF(LLP1) THEN WRITE(NOUT,FMT='('' (JGL,G%NLOEN,G%NMEN) '')') WRITE(NOUT,FMT='(8(1X,''('',I4,I4,I4,'')''))')& &(JGL,G%NLOEN(JGL),G%NMEN(JGL),JGL=1,R%NDGL) ENDIF ALLOCATE(G%NDGLU(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'G%NDGLU ',SIZE(G%NDGLU ),SHAPE(G%NDGLU ) IDGLU(:,:) = 0 G%NDGLU(:) = 0 DO JGL=1,R%NDGNH DO JM=0,G%NMEN(JGL) IDGLU(JM,JGL) = 1 ENDDO ENDDO DO JM=0,R%NSMAX DO JGL=1,R%NDGNH G%NDGLU(JM) = G%NDGLU(JM)+IDGLU(JM,JGL) ENDDO ENDDO IF(LLP1) THEN WRITE(NOUT,FMT='('' (JM,G%NDGLU) '')') WRITE(NOUT,FMT='(10(1X,''('',I4,I4,'')''))')& &(JM,G%NDGLU(JM),JM=0,R%NSMAX) ENDIF ENDIF ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SETUP_GEOM END MODULE SETUP_GEOM_MOD ectrans-1.8.0/src/trans/common/internal/mysendset_mod.F900000664000175000017500000000345315174631767023545 0ustar alastairalastair! (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. ! MODULE MYSENDSET_MOD CONTAINS FUNCTION MYSENDSET(KSETS,KMYSET,KSET) !**** *MYSENDSET* RETURNS SET NUMBER TO SEND TO ! Purpose. ! -------- ! !** Interface. ! ---------- ! ISENDSET = MYSENDSET(KSETS,KMYSET,KSET) ! Explicit arguments : ! -------------------- ! input: KSETS ! Implicit arguments : NONE ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! NONE ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-03 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS IMPLICIT NONE INTEGER(KIND=JPIM) :: MYSENDSET INTEGER(KIND=JPIM),INTENT(IN) :: KSETS,KMYSET,KSET ! ------------------------------------------------------------------ !* 1. Check input argument for validity ! --------------------------------- IF(KSETS < 1 .OR. KMYSET > KSETS .OR. KSET > KSETS-1) THEN CALL ABORT_TRANS(' MYSENDSET: INVALID ARGUMENT ') ELSE !* 2. Compute output parameters ! ------------------------- MYSENDSET = MOD(KMYSET+KSET-1,KSETS)+1 ENDIF END FUNCTION MYSENDSET END MODULE MYSENDSET_MOD ectrans-1.8.0/src/trans/common/internal/sumplatbeq_mod.F900000664000175000017500000002061615174631767023707 0ustar alastairalastair! (C) Copyright 2006- ECMWF. ! (C) Copyright 2006- 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. ! MODULE SUMPLATBEQ_MOD CONTAINS SUBROUTINE SUMPLATBEQ(KDGSA,KDGL,KPROC,KPROCA,KLOENG,LDSPLIT,LDEQ_REGIONS,& &PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& &KMEDIAP,KRESTM,KINDIC,KLAST) !**** *SUMPLATBEQ * - Routine to initialize parallel environment ! (latitude partitioning for LEQ_REGIONS=T) ! Purpose. ! -------- !** Interface. ! ---------- ! *CALL* *SUMPLATBEQ * ! Explicit arguments - input : ! -------------------- ! KDGSA -first latitude (grid-space) ! (may be different from NDGSAG) ! KDGL -last latitude ! KPROC -total number of processors ! KPROCA -number of processors in A direction ! KLOENG -actual number of longitudes per latitude. ! LDSPLIT -true for latitudes shared between sets ! LDEQ_REGIONS -true if eq_regions partitioning ! PWEIGHT -weight per grid-point if weighted distribution ! LDWEIGHTED_DISTR -true if weighted distribution ! Explicit arguments - output: ! -------------------- ! PMEDIAP -mean weight per PE if weighted distribution ! KMEDIAP -mean number of grid points per PE ! KPROCAGP -number of grid points per A set ! KRESTM -number of PEs with one extra point ! KINDIC -intermediate quantity for 'sumplat' ! KLAST -intermediate quantity for 'sumplat' ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. NONE. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! G. Mozdzynski ! Modifications. ! -------------- ! Original : April 2006 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM ,JPRD USE TPM_DISTR ,ONLY : MYPROC USE TPM_GEN ,ONLY : NOUT, NERR USE EQ_REGIONS_MOD ,ONLY : N_REGIONS USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE ! * DUMMY: INTEGER(KIND=JPIM),INTENT(IN) :: KDGSA INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KPROC INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA INTEGER(KIND=JPIM),INTENT(IN) :: KLOENG(KDGSA:KDGL) REAL(KIND=JPRD),INTENT(IN) :: PWEIGHT(:) LOGICAL,INTENT(IN) :: LDSPLIT LOGICAL,INTENT(IN) :: LDEQ_REGIONS LOGICAL,INTENT(INOUT) :: LDWEIGHTED_DISTR REAL(KIND=JPRD),INTENT(OUT) :: PMEDIAP INTEGER(KIND=JPIM),INTENT(OUT) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(OUT) :: KRESTM INTEGER(KIND=JPIM),INTENT(OUT) :: KINDIC(KPROCA) INTEGER(KIND=JPIM),INTENT(OUT) :: KLAST(KPROCA) INTEGER(KIND=JPIM),INTENT(OUT) :: KPROCAGP(KPROCA) ! * LOCAL: ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: ICOMP, IGL, IMAXI, IMEDIA, IMEDIAP, ITOT, JA, JB, IA, JGL,& &ILAST,IREST,IPE,I2REGIONS,IGP REAL(KIND=JPRD) :: ZMEDIA, ZCOMP LOGICAL :: LLDONE ! ----------------------------------------------------------------- !* 1. COMPUTATION OF KMEDIAP, KRESTM, KINDIC, KLAST. ! ---------------------------------------------- 100 CONTINUE ! * Computation of KMEDIAP and KRESTM. IF (.NOT.LDWEIGHTED_DISTR) THEN IMEDIA = SUM(KLOENG(KDGSA:KDGL)) KMEDIAP = IMEDIA / KPROC IF( KPROC > 1 )THEN ! test if KMEDIAP is too small and no more than 2 asets would be required ! for the first latitude IF( LDSPLIT )THEN I2REGIONS=N_REGIONS(1)+N_REGIONS(2) IF( KMEDIAP < (KLOENG(KDGSA)-1)/I2REGIONS+1 )THEN WRITE(NERR,'("SUMPLATBEQ: KMEDIAP=",I6," I2REGIONS=",I3," KLOENG(KDGSA)=",I4)')& &KMEDIAP,I2REGIONS,KLOENG(KDGSA) CALL ABORT_TRANS ('SUMPLATBEQ: NPROC TOO BIG FOR THIS RESOLUTION, LDSPLIT=T') ENDIF ELSE ! test for number asets too large for the number of latitudes IF( KPROCA > KDGL )THEN WRITE(NERR,'("SUMPLATBEQ: KMEDIAP=",I6," KPROCA=",I4," KDGL=",I4)')& &KMEDIAP,KPROCA,KDGL CALL ABORT_TRANS ('SUMPLATBEQ: NPROC TOO BIG FOR THIS RESOLUTION, LDSPLIT=F') ENDIF ENDIF ENDIF KRESTM = IMEDIA - KMEDIAP * KPROC IF (KRESTM > 0) KMEDIAP = KMEDIAP + 1 ELSE ZMEDIA = SUM(PWEIGHT(:)) PMEDIAP = ZMEDIA / KPROC ENDIF ! * Computation of intermediate quantities KINDIC and KLAST IF (LDSPLIT) THEN KPROCAGP(:)=0 IREST = 0 ILAST =0 IPE=0 ZCOMP=0 IGP=0 DO JA=1,KPROCA ICOMP=0 DO JB=1,N_REGIONS(JA) IF( LDWEIGHTED_DISTR )THEN DO WHILE ( ( JA == KPROCA .OR. ZCOMP < PMEDIAP ) .AND. IGP < SIZE(PWEIGHT) ) IGP = IGP + 1 ICOMP = ICOMP + 1 ZCOMP = ZCOMP + PWEIGHT(IGP) ENDDO ZCOMP = ZCOMP - PMEDIAP ELSE IPE=IPE+1 IF (IPE <= KRESTM .OR. KRESTM == 0) THEN ICOMP = ICOMP + KMEDIAP ELSE ICOMP = ICOMP + (KMEDIAP-1) ENDIF ENDIF ENDDO KPROCAGP(JA)=ICOMP ITOT = IREST IGL = ILAST+1 DO JGL=IGL,KDGL ILAST = JGL IF(ITOT+KLOENG(JGL) < ICOMP) THEN ITOT = ITOT+KLOENG(JGL) ELSEIF(ITOT+KLOENG(JGL) == ICOMP) THEN IREST = 0 KLAST(JA) = JGL KINDIC(JA) = 0 EXIT ELSE IREST = KLOENG(JGL) -(ICOMP-ITOT) KLAST(JA) = JGL KINDIC(JA) = JGL EXIT ENDIF ENDDO ENDDO IF( LDWEIGHTED_DISTR )THEN IF( KLAST(KPROCA) /= KDGL )THEN DO JA=1,KPROCA IF( MYPROC == 1 )THEN WRITE(NOUT,'("SUMPLATBEQ_MOD: JA=",I3," KLAST=",I3," KINDIC=",I3)')& &JA,KLAST(JA),KINDIC(JA) ENDIF ENDDO WRITE(NOUT,'("SUMPLATBEQ: LWEIGHTED_DISTR=T FAILED TO PARTITION GRID, REVERTING TO ",& & " LWEIGHTED_DISTR=F PARTITIONING")') LDWEIGHTED_DISTR=.FALSE. GOTO 100 ENDIF ENDIF IF( SUM(KPROCAGP(:)) /= SUM(KLOENG(KDGSA:KDGL)) )THEN IF( MYPROC == 1 )THEN WRITE(NERR,'("SUM(KPROCAGP(:))=",I12)')SUM(KPROCAGP(:)) WRITE(NERR,'("SUM(KLOENG(:))=",I12)')SUM(KLOENG(KDGSA:KDGL)) ENDIF CALL ABORT_TRANS ('SUMPLATBEQ: PROBLEM IN PARTITIONING ') ENDIF ELSE IF( LDWEIGHTED_DISTR )THEN CALL ABORT_TRANS ('SUMPLATBEQ: LSPLIT=F NOT SUPPORTED FOR WEIGHTED DISTRIBUTION ') ENDIF KINDIC(:) = 0 LLDONE=.FALSE. IMEDIAP=KMEDIAP IF( MYPROC == 1 )THEN WRITE(NOUT,'("SUMPLATBEQ: IMEDIAP=",I6)')IMEDIAP ENDIF DO WHILE(.NOT.LLDONE) ! loop until a satisfactory distribution can be found IA=1 IMAXI=IMEDIAP*N_REGIONS(IA) DO JGL=1,KDGL KLAST(IA)=JGL IMAXI=IMAXI-KLOENG(JGL) IF( IA == KPROCA .AND. JGL == KDGL )THEN IF( MYPROC == 1 )THEN WRITE(NOUT,'("SUMPLATBEQ: EXIT 1")') ENDIF EXIT ENDIF IF( IA == KPROCA .AND. JGL < KDGL )THEN IF( MYPROC == 1 )THEN WRITE(NOUT,'("SUMPLATBEQ: EXIT 2")') ENDIF KLAST(KPROCA)=KDGL EXIT ENDIF IF( IA < KPROCA .AND. JGL == KDGL )THEN DO JA=KPROCA,IA+1,-1 KLAST(JA)=KDGL+JA-KPROCA ENDDO DO JA=KPROCA,2,-1 IF( KLAST(JA) <= KLAST(JA-1) )THEN KLAST(JA-1)=KLAST(JA)-1 ENDIF ENDDO IF( MYPROC == 1 )THEN WRITE(NOUT,'("SUMPLATBEQ: EXIT 3")') ENDIF EXIT ENDIF IF( IMAXI <= 0 )THEN IA=IA+1 IMAXI=IMAXI+IMEDIAP*N_REGIONS(IA) ENDIF ENDDO IF( KPROCA > 1 .AND. KLAST(KPROCA) == KLAST(KPROCA-1) )THEN IMEDIAP=IMEDIAP-1 IF( MYPROC == 1 )THEN WRITE(NOUT,'("SUMPLATBEQ: REDUCING IMEDIAP=",I6)')IMEDIAP ENDIF IF( IMEDIAP <= 0 )THEN CALL ABORT_TRANS ('SUMPLATBEQ: PROBLEM PARTITIONING WITH LSPLIT=F, IMEDIAP <= 0') ENDIF ELSE LLDONE=.TRUE. ENDIF ENDDO ENDIF END SUBROUTINE SUMPLATBEQ END MODULE SUMPLATBEQ_MOD ectrans-1.8.0/src/trans/common/internal/field_split_mod.F900000775000175000017500000000654215174631767024035 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE FIELD_SPLIT_MOD CONTAINS SUBROUTINE FIELD_SPLIT(KBLK,KF_GP,KKF_UV_G,KVSETUV,KVSETSC,& & KSTUV_G,KENUV_G,KF_UV_G,KSTSC_G,KENSC_G,KF_SCALARS_G,& & KSTUV,KENUV,KF_UV,KSTSC,KENSC,KF_SCALARS) !**** *FIELD_SPLIT* - Split fields ! Purpose. ! -------- ! Split fields !** Interface. ! ---------- ! CALL FIELD_SPLIT(...) ! Explicit arguments : ! -------------------- ! KBLK - block number ! KF_GP - total number of output gridpoint fields ! KKF_UV_G - global number of spectral u-v fields ! KVSETUV - IVSETUV from SHUFFLE ! KVSETSC - IVSETUV from SHUFFLE ! All the following output arguments are quantities for THIS packet. ! KSTUV_G - ! KENUV_G - ! KF_UV_G - ! KSTSC_G - ! KENSC_G - ! KF_SCALARS_G - ! KSTUV - ! KENUV - ! KF_UV - ! KSTSC - ! KENSC - ! KF_SCALARS - ! Externals. NONE ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE EC_PARKIND,ONLY: JPIM USE TPM_GEN, ONLY: NPROMATR USE TPM_DISTR, ONLY: MYSETV, NPRTRV ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KBLK,KF_GP,KKF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KVSETUV(:),KVSETSC(:) INTEGER(KIND=JPIM), INTENT(OUT) :: KSTUV_G,KENUV_G,KF_UV_G,KSTSC_G,KENSC_G,KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(OUT) :: KSTUV,KENUV,KF_UV,KSTSC,KENSC,KF_SCALARS ! Local variables INTEGER(KIND=JPIM) :: ISTF,IENF,J ! ------------------------------------------------------------------ ISTF = (KBLK-1)*NPROMATR+1 IENF = MIN(KBLK*NPROMATR,KF_GP) KSTUV_G = (KBLK-1)*NPROMATR/2+1 KENUV_G = MIN(KBLK*NPROMATR/2,KKF_UV_G) IF(ISTF > 2*KKF_UV_G) KSTUV_G = KENUV_G+1 KF_UV_G = KENUV_G-KSTUV_G+1 KSTSC_G = MAX(ISTF-2*KKF_UV_G,1) KENSC_G = MAX(IENF-2*KKF_UV_G,0) KF_SCALARS_G = KENSC_G-KSTSC_G+1 ! Spectral fields distributed over fields IF(NPRTRV > 1) THEN KF_UV = 0 KSTUV = 1 DO J=1,KSTUV_G-1 IF(KVSETUV(J) == MYSETV) THEN KSTUV = KSTUV+1 ENDIF ENDDO KENUV = KSTUV-1 DO J=KSTUV_G,KENUV_G IF(KVSETUV(J) == MYSETV) THEN KF_UV = KF_UV+1 KENUV = KENUV+1 ENDIF ENDDO KF_SCALARS = 0 KSTSC = 1 DO J=1,KSTSC_G-1 IF(KVSETSC(J) == MYSETV) THEN KSTSC =KSTSC+1 ENDIF ENDDO KENSC = KSTSC-1 DO J=KSTSC_G,KENSC_G IF(KVSETSC(J) == MYSETV) THEN KF_SCALARS = KF_SCALARS+1 KENSC = KENSC+1 ENDIF ENDDO ELSE ! Spectral fields not distributed over fields KF_UV = KF_UV_G KSTUV = KSTUV_G KENUV = KENUV_G KF_SCALARS = KF_SCALARS_G KSTSC = KSTSC_G KENSC = KENSC_G ENDIF ! ------------------------------------------------------------------ END SUBROUTINE FIELD_SPLIT END MODULE FIELD_SPLIT_MOD ectrans-1.8.0/src/trans/common/internal/tpm_pol.F900000775000175000017500000000610515174631767022345 0ustar alastairalastair! (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. ! MODULE TPM_POL ! MODIFICATIONS. ! -------------- ! R. El Khatib 17-Feb-2016 Optional allocation/computation of DDC/DDD/DDE ! since they are (big and) not used in supolf. USE EC_PARKIND, ONLY: JPRD, JPIM IMPLICIT NONE SAVE REAL(KIND=JPRD),ALLOCATABLE :: DDC(:,:), DDD(:,:), DDE(:,:) REAL(KIND=JPRD),ALLOCATABLE :: DDA(:), DDI(:), DDH(:) REAL(KIND=JPRD),ALLOCATABLE :: DFA(:), DFB(:), DFF(:), DFG(:), DFI(:), DFH(:) CONTAINS !====================================================================== SUBROUTINE INI_POL(KNSMAX,LDFAST) INTEGER(KIND=JPIM), INTENT(IN) :: KNSMAX LOGICAL, INTENT(IN), OPTIONAL :: LDFAST REAL(KIND=JPRD) :: DC,DD,DE INTEGER(KIND=JPIM) :: KKN, KKM INTEGER(KIND=JPIM) :: JN, JM LOGICAL :: LLFAST DC(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPRD)*REAL(KKN+KKM-1,JPRD)& &*REAL(KKN+KKM-3,JPRD))& &/ (REAL(2*KKN-3,JPRD)*REAL(KKN+KKM,JPRD)& &*REAL(KKN+KKM-2,JPRD)) ) DD(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPRD)*REAL(KKN+KKM-1,JPRD)& &*REAL(KKN-KKM+1,JPRD))& &/ (REAL(2*KKN-1,JPRD)*REAL(KKN+KKM,JPRD)& &*REAL(KKN+KKM-2,JPRD)) ) DE(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPRD)*REAL(KKN-KKM,JPRD))& &/ (REAL(2*KKN-1,JPRD)*REAL(KKN+KKM,JPRD)) ) IF (PRESENT(LDFAST)) THEN LLFAST=LDFAST ELSE LLFAST=.FALSE. ENDIF IF (.NOT.LLFAST) ALLOCATE( DDC(0:KNSMAX,0:KNSMAX) ) IF (.NOT.LLFAST) ALLOCATE( DDD(0:KNSMAX,0:KNSMAX) ) IF (.NOT.LLFAST) ALLOCATE( DDE(0:KNSMAX,0:KNSMAX) ) ALLOCATE( DDA(0:KNSMAX) ) ALLOCATE( DDI(0:KNSMAX) ) ALLOCATE( DDH(0:KNSMAX) ) ALLOCATE( DFA(0:KNSMAX) ) ALLOCATE( DFB(0:KNSMAX) ) ALLOCATE( DFF(0:KNSMAX) ) ALLOCATE( DFG(0:KNSMAX) ) ALLOCATE( DFI(0:KNSMAX) ) ALLOCATE( DFH(0:KNSMAX) ) DO JN=1,KNSMAX DFA(JN) = 1._JPRD/SQRT(REAL(JN*(JN+1),JPRD)) DFB(JN) = SQRT(REAL(2*JN+1,JPRD)/REAL(JN*(JN+1),JPRD)) DFF(JN) = REAL(2*JN-1,JPRD)/REAL(JN,JPRD) DFG(JN) = REAL(JN-1,JPRD)/REAL(JN,JPRD) DFI(JN) = REAL(JN,JPRD) DFH(JN) = SQRT(REAL(2*JN+1,JPRD)/REAL(2*JN,JPRD)) ENDDO IF (.NOT.LLFAST) THEN DO JN=3,KNSMAX DO JM=2,JN-1 DDC(JM,JN) = DC(JN,JM) DDD(JM,JN) = DD(JN,JM) DDE(JM,JN) = DE(JN,JM) ENDDO ENDDO ENDIF DO JN=1,KNSMAX DDA(JN) = 1._JPRD/SQRT(REAL(JN*(JN+1),JPRD)) DDI(JN) = REAL(JN,JPRD) DDH(JN) = SQRT(REAL(2*JN+1,JPRD)/REAL(2*JN,JPRD)) ENDDO END SUBROUTINE INI_POL SUBROUTINE END_POL IF (ALLOCATED (DDC) ) DEALLOCATE( DDC ) IF (ALLOCATED (DDD) ) DEALLOCATE( DDD ) IF (ALLOCATED (DDE) ) DEALLOCATE( DDE ) DEALLOCATE( DDA ) DEALLOCATE( DDI ) DEALLOCATE( DDH ) DEALLOCATE( DFA ) DEALLOCATE( DFB ) DEALLOCATE( DFF ) DEALLOCATE( DFG ) DEALLOCATE( DFI ) DEALLOCATE( DFH ) END SUBROUTINE END_POL END MODULE TPM_POL ectrans-1.8.0/src/trans/common/internal/supol_mod.F900000664000175000017500000001203015174631767022663 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE SUPOL_MOD CONTAINS SUBROUTINE SUPOL(KNSMAX,PDDMU,PFN,PDDPOL) !**** *SUPOL * - Routine to compute the Legendre polynomials ! Purpose. ! -------- ! For a given value of mu, computes the Legendre polynomials. !** Interface. ! ---------- ! *CALL* *SUPOL(...) ! Explicit arguments : ! -------------------- ! KNSMAX : Truncation (triangular) [in] ! PDDMU : Abscissa at which the polynomials are computed (mu) [in] ! PFN : Fourier coefficients of series expansion ! for the ordinary Legendre polynomials [in] ! PDDPOL : Polynomials (the first index is m and the second n) [out] ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! See documentation about spectral transforms ! (doc (IDTS) by K. Yessad, appendix 3, or doc (NTA30) by M. Rochas) ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-10-15 ! K. YESSAD (MAY 1998): modification to avoid underflow. ! M.Hamrud 01-Oct-2003 CY28 Cleaning ! R. El Khatib 11-Apr-2007 Emulation of vectorized quadruple precision ! on NEC ! K. YESSAD (NOV 2008): make consistent arp/SUPOLA and tfl/SUPOL. ! Nils Wedi + Mats Hamrud, 2009-02-05 revised following Swarztrauber, 2002 ! R. El Khatib 30-Apr-2013 Open-MP parallelization ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM USE TPM_POL ,ONLY : DDI, DDA, DDH, DDE, DDC, DDD IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNSMAX REAL(KIND=JPRD) ,INTENT(IN) :: PDDMU REAL(KIND=JPRD) ,INTENT(IN) :: PFN(0:KNSMAX,0:KNSMAX) REAL(KIND=JPRD) ,INTENT(OUT) :: PDDPOL(0:KNSMAX,0:KNSMAX) REAL(KIND=JPRD) :: ZDLX,ZDLX1,ZDLSITA,ZDL1SITA,ZDLS,ZDLK,ZDLLDN INTEGER(KIND=JPIM) :: JM, JN, JK REAL(KIND=JPRD) :: Z ! ------------------------------------------------------------------ !* 1. First two columns. ! ------------------ ZDLX=PDDMU ZDLX1=ACOS(ZDLX) ZDLSITA=SQRT(1.0_JPRD-ZDLX*ZDLX) PDDPOL(0,0)=1._JPRD ZDLLDN = 0.0_JPRD ! IF WE ARE LESS THAN 1Meter FROM THE POLE, IF(ABS(REAL(ZDLSITA,KIND(Z))) <= SQRT(EPSILON(Z)))THEN ZDLX=1._JPRD ZDLSITA=0._JPRD ZDL1SITA=0._JPRD ELSE ZDL1SITA=1.0_JPRD/ZDLSITA ENDIF !* ordinary Legendre polynomials from series expansion ! --------------------------------------------------- ! even N !$OMP PARALLEL DO PRIVATE(JN,ZDLK,ZDLLDN,JK) DO JN=2,KNSMAX,2 ZDLK = 0.5_JPRD*PFN(JN,0) ZDLLDN = 0.0_JPRD ! represented by only even k DO JK=2,JN,2 ! normalised ordinary Legendre polynomial == \overbar{P_n}^0 ZDLK = ZDLK + PFN(JN,JK)*COS(DDI(JK)*ZDLX1) ! normalised associated Legendre polynomial == \overbar{P_n}^1 ZDLLDN = ZDLLDN + DDA(JN)*PFN(JN,JK)*DDI(JK)*SIN(DDI(JK)*ZDLX1) ENDDO PDDPOL(0,JN) = ZDLK PDDPOL(1,JN) = ZDLLDN ENDDO !$OMP END PARALLEL DO ! odd N !$OMP PARALLEL DO PRIVATE(JN,ZDLK,ZDLLDN,JK) DO JN=1,KNSMAX,2 ZDLK = 0.0_JPRD ZDLLDN = 0.0_JPRD ! represented by only odd k DO JK=1,JN,2 ! normalised ordinary Legendre polynomial == \overbar{P_n}^0 ZDLK = ZDLK + PFN(JN,JK)*COS(DDI(JK)*ZDLX1) ! normalised associated Legendre polynomial == \overbar{P_n}^1 ZDLLDN = ZDLLDN + DDA(JN)*PFN(JN,JK)*DDI(JK)*SIN(DDI(JK)*ZDLX1) ENDDO PDDPOL(0,JN) = ZDLK PDDPOL(1,JN) = ZDLLDN ENDDO !$OMP END PARALLEL DO ! ------------------------------------------------------------------ !* 2. Diagonal (the terms 0,0 and 1,1 have already been computed) ! Belousov, equation (23) ! ----------------------------------------------------------- ZDLS=ZDL1SITA*TINY(ZDLS) #ifdef VPP !OCL SCALAR #endif DO JN=2,KNSMAX PDDPOL(JN,JN)=PDDPOL(JN-1,JN-1)*ZDLSITA*DDH(JN) IF ( ABS(PDDPOL(JN,JN)) < ZDLS ) PDDPOL(JN,JN)=0.0_JPRD ENDDO ! ------------------------------------------------------------------ !* 3. General recurrence (Belousov, equation 17) ! ----------------------------------------- DO JN=3,KNSMAX !DIR$ IVDEP !OCL NOVREC DO JM=2,JN-1 PDDPOL(JM,JN)=DDC(JM,JN)*PDDPOL(JM-2,JN-2)& &-DDD(JM,JN)*PDDPOL(JM-2,JN-1)*ZDLX & &+DDE(JM,JN)*PDDPOL(JM ,JN-1)*ZDLX ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE SUPOL END MODULE SUPOL_MOD ectrans-1.8.0/src/trans/common/internal/tpm_distr.F900000775000175000017500000002240615174631767022702 0ustar alastairalastair! (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. ! MODULE TPM_DISTR ! Module for distributed memory environment. USE EC_PARKIND ,ONLY : JPIM ,JPRD, JPIB IMPLICIT NONE SAVE !* Variables describing distributed memory parallelization INTEGER(KIND=JPIM) :: NPROC ! Number of processors (NPRGPNS*NPRGPEW) INTEGER(KIND=JPIM) :: NPRGPNS ! No. of sets in N-S direction (grid-point space) INTEGER(KIND=JPIM) :: NPRGPEW ! No. of sets in E-W direction (grid-point space) INTEGER(KIND=JPIM) :: NPRTRW ! No. of sets in wave direction (spectral space) INTEGER(KIND=JPIM) :: NPRTRV ! NPROC/NPRTRW INTEGER(KIND=JPIM) :: NPRTRNS ! No. of sets in N-S direction (Fourier space) ! (always equal to NPRTRW) LOGICAL :: LEQ_REGIONS ! TRUE - Use new eq_regions partitioning ! FALSE- Use old NPRGPNS x NPRGPEW partitioning INTEGER(KIND=JPIM) :: MYPROC ! My processor number INTEGER(KIND=JPIM) :: MYSETW ! My set number in wave direction (spectral space) INTEGER(KIND=JPIM) :: MYSETV ! My set number in field direction(S.S and F.S) INTEGER(KIND=JPIM) :: MTAGLETR ! Tag INTEGER(KIND=JPIM) :: MTAGML ! Tag INTEGER(KIND=JPIM) :: MTAGLG ! Tag INTEGER(KIND=JPIM) :: MTAGGL ! Tag INTEGER(KIND=JPIM) :: MTAGPART ! Tag INTEGER(KIND=JPIM) :: MTAGDISTSP ! Tag INTEGER(KIND=JPIM) :: MTAGLM ! Tag INTEGER(KIND=JPIM) :: MTAGDISTGP ! Tag INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPRCIDS(:) ! Array containing the process ids TYPE DISTR_TYPE LOGICAL :: LGRIDONLY ! TRUE - only grid space structures are available LOGICAL :: LWEIGHTED_DISTR ! TRUE - weighted distribution LOGICAL :: LSPLIT ! TRUE - latitudes are shared between a-sets LOGICAL :: LCPNMONLY ! TRUE - Compute Legendre polynomials only, not FFTs ! SPECTRAL SPACE INTEGER(KIND=JPIM) :: NUMP ! No. of spectral waves handled by this processor INTEGER(KIND=JPIM) :: NSPEC ! No. of complex spectral coefficients (on this PE) INTEGER(KIND=JPIM) :: NSPEC2 ! 2*NSPEC INTEGER(KIND=JPIM) :: NSPEC2MX ! maximun NSPEC2 among all PEs INTEGER(KIND=JPIM) :: NTPEC2 ! cf. NSPEC2 but for truncation NTMAX INTEGER(KIND=JPIM) :: NUMTP ! cf. NUMP but for truncation NTMAX INTEGER(KIND=JPIM) :: NSPOLEGL ! No. of legendre polynomials on this PE INTEGER(KIND=JPIM) :: NLEI3D ! (NLEI3-1)/NPRTRW+1 INTEGER(KIND=JPIM) ,ALLOCATABLE :: MYMS(:) ! Wave numbers handled by this PE INTEGER(KIND=JPIM) ,ALLOCATABLE :: NUMPP(:) ! No. of wave numbers each wave set is ! responsible for INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPOSSP(:) ! Not needed in transform? INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPROCM(:) ! Process that does the calc. for certain ! wavenumber M INTEGER(KIND=JPIM) ,ALLOCATABLE :: NDIM0G(:) ! Defines partitioning of global spectral ! fields among PEs INTEGER(KIND=JPIM) ,ALLOCATABLE :: NASM0(:) ! Address in a spectral array of (m, n=m) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NATM0(:) ! Same as NASM0 but for NTMAX INTEGER(KIND=JPIM) ,ALLOCATABLE :: NALLMS(:) ! Wave numbers for all a-set concatenated ! together to give all wave numbers in a-set ! order. Used when global spectral norms ! have to be gathered. INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPTRMS(:) ! Pointer to the first wave number of a given ! a-set in nallms array. ! Legendre polynomials INTEGER(KIND=JPIM) ,ALLOCATABLE :: NLATLS(:,:) ! First latitude for which each a-set,bset calcul. INTEGER(KIND=JPIM) ,ALLOCATABLE :: NLATLE(:,:) ! Last latitude for which each a-set,bset calcul. INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPMT(:) ! Adress for legendre polynomial for ! given M (NTMAX) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPMS(:) ! Adress for legendre polynomial for ! given M (NSMAX) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPMG(:) ! Global version of NPMS ! FOURIER SPACE INTEGER(KIND=JPIM) :: NDGL_FS ! Number of rows of latitudes for which this process is ! performing Fourier Space calculations INTEGER(KIND=JPIB) ,ALLOCATABLE :: NSTAGTF(:) ! Offset for specific latitude in ! Fourier/gridpoint buffer INTEGER(KIND=JPIM) :: NLENGTF ! Second dimension of Fourier/gridpoint buffer ! (sum of (NLOEN+3) over local latitudes) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NULTPP(:) ! No of lats. for each wave_set (F.S) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPROCL(:) ! Process responsible for each lat. (F.S) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPTRLS(:) ! Pointer to first lat. (F.S) ! NSTAGT0B to NLENGT0B: help arrays for spectral to fourier space transposition ! For index I, offset from which to take data from send buffer of TRMTOL to be sent to processor I INTEGER(KIND=JPIM) ,ALLOCATABLE :: NSTAGT0B(:) ! (1:NPRTRW+1) ! For index I, offset at which to put data in receive buffer of TRLTOM for sending processor I INTEGER(KIND=JPIM) ,ALLOCATABLE :: NSTAGT1B(:) ! (1:NPRTRW+1) ! For wavenumber JM (first dimension) and latitude KGL (second dimension), this gives the offset ! into the TRLTOM/TRMTOL send/receive buffers (FOUBUF, FOUBUF_IN) for JM and KGL, starting from the ! offset for the processor (i.e. this must be used in combination with NSTAGT0B) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPNTGTB0(:,:) ! (0:R%NSMAX,D%NDGL_FS) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPNTGTB1(:,:) ! (D%NUMP,R%NDGL) ! For index I, this tells you how many values will be transferred from this processor to processor I ! in TRMTOL and from processor I to this processor in TRLTOM INTEGER(KIND=JPIM) ,ALLOCATABLE :: NLTSFTB(:) ! (1:NPRTRW+1) ! For index I, this tells you how many values will be transferred from this processor to processor I ! in TRLTOM and from processor I to this processor in TRMTOL INTEGER(KIND=JPIM) ,ALLOCATABLE :: NLTSGTB(:) ! (1:NPRTRW+1) ! For index I, this tells you from where in the TRLTOM send buffer to take the data to send to ! processor I INTEGER(KIND=JPIM) ,ALLOCATABLE :: MSTABF(:) ! (1:NPRTRW+1) ! Size of FOUBUF_IN, FOUBUF, except for the fields (i.e. this will be multiplied by 2 * KFIELD) INTEGER(KIND=JPIM) :: NLENGT0B INTEGER(KIND=JPIM) :: NLENGT1B ! (only used in GPU code path) ! GRIDPOINT SPACE INTEGER(KIND=JPIM) :: NDGL_GP ! D%NLSTLAT(MY_REGION_NS)-D%NFRSTLOFF INTEGER(KIND=JPIM) ,ALLOCATABLE :: NFRSTLAT(:) ! First lat of each a-set INTEGER(KIND=JPIM) ,ALLOCATABLE :: NLSTLAT(:) ! Last lat of each a-set INTEGER(KIND=JPIM) :: NFRSTLOFF ! Offset for first lat of own a-set ! i.e. NFRSTLOFF=NFRSTLAT(MYSETA)-1 INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPTRLAT(:) ! Pointer to start of latitude INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPTRFRSTLAT(:) ! Pointer to the first latitude of each ! a-set in NSTA and NONL arrays INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPTRLSTLAT(:) ! Pointer to the last latitude of each ! a-set in NSTA and NONL arrays INTEGER(KIND=JPIM) :: NPTRFLOFF ! Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. NPTRFRSTLAT(MYSETA)-1 LOGICAL ,ALLOCATABLE :: LSPLITLAT(:) ! True if latitude is split over 2 a-sets ! NSTA(R%NDGL+NPRGPNS-1,NPRGPEW) : Position of first grid column ! for the latitudes on a processor. The information is ! available for all processors. The b-sets are distinguished ! by the last dimension of NSTA(). The latitude band for ! each a-set is addressed by NPTRFRSTLAT(JASET), ! NPTRLSTLAT(JASET), and NPTRFLOFF=NPTRFRSTLAT(MYSETA) on ! this processors a-set. Each split latitude has two entries ! in NSTA(,:) which necessitates the rather complex ! addressing of NSTA(,:) and the overdimensioning of NSTA by ! NPRGPNS. ! NONL(R%NDGL+NPRGPNS-1,NPRGPEW) : Number of grid columns for ! the latitudes on a processor. Similar to NSTA() in data ! structure. INTEGER(KIND=JPIM) ,ALLOCATABLE :: NSTA(:,:) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NONL(:,:) INTEGER(KIND=JPIM) :: NGPTOT ! Total number of grid columns on this PE INTEGER(KIND=JPIM) :: NGPTOTG ! Total number of grid columns on the Globe INTEGER(KIND=JPIM) :: NGPTOTMX ! Maximum number of grid columns on any of the PEs INTEGER(KIND=JPIM) ,ALLOCATABLE :: NGPTOTL(:,:) ! Number of grid columns on each PE. REAL(KIND=JPRD) ,ALLOCATABLE :: RWEIGHT(:) ! Weight per grid-point (if weighted distribution) INTEGER(KIND=JPIM) ,ALLOCATABLE :: NPROCA_GP(:) ! Number of grid-points per a-set INTEGER(KIND=JPIB), ALLOCATABLE :: OFFSETS_GEMM1(:), OFFSETS_GEMM2(:), OFFSETS_GEMM_MATRIX(:) INTEGER(KIND=JPIM), ALLOCATABLE :: LEGENDRE_MATRIX_STRIDES(:) END TYPE DISTR_TYPE TYPE(DISTR_TYPE),ALLOCATABLE,TARGET :: DISTR_RESOL(:) TYPE(DISTR_TYPE),POINTER :: D END MODULE TPM_DISTR ectrans-1.8.0/src/trans/common/internal/pre_suleg_mod.F900000775000175000017500000000353315174631767023521 0ustar alastairalastair! (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. ! MODULE PRE_SULEG_MOD IMPLICIT NONE CONTAINS SUBROUTINE PRE_SULEG USE EC_PARKIND, ONLY: JPRD, JPIM USE TPM_GEN, ONLY: NPRINTLEV, NOUT USE TPM_DIM, ONLY: R USE TPM_CONSTANTS, ONLY: RA USE TPM_DISTR, ONLY: D USE TPM_FIELDS, ONLY: F INTEGER(KIND=JPIM) :: IM, ICOUNT,JMLOC,JN LOGICAL :: LLP1,LLP2 LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 ICOUNT = 0 DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) DO JN=IM,R%NTMAX+2 ICOUNT = ICOUNT+1 ENDDO ENDDO ALLOCATE(F%REPSNM(ICOUNT)) IF (LLP2) WRITE(NOUT,9) 'F%REPSNM ',SIZE(F%REPSNM ),SHAPE(F%REPSNM ) ALLOCATE(F%RN(-1:R%NTMAX+3)) IF (LLP2) WRITE(NOUT,9) 'F%RN ',SIZE(F%RN ),SHAPE(F%RN ) ALLOCATE(F%RLAPIN(-1:R%NSMAX+2)) IF (LLP2) WRITE(NOUT,9) 'F%RLAPIN ',SIZE(F%RLAPIN ),SHAPE(F%RLAPIN ) ALLOCATE(F%NLTN(-1:R%NTMAX+3)) IF (LLP2) WRITE(NOUT,9) 'F%NLTN ',SIZE(F%NLTN ),SHAPE(F%NLTN ) ICOUNT = 0 DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) DO JN=IM,R%NTMAX+2 ICOUNT = ICOUNT+1 F%REPSNM(ICOUNT) = SQRT(REAL(JN*JN-IM*IM,JPRD)/& &REAL(4*JN*JN-1,JPRD)) ENDDO ENDDO DO JN=-1,R%NTMAX+3 F%RN(JN) = REAL(JN,JPRD) F%NLTN(JN) = R%NTMAX+2-JN ENDDO F%RLAPIN(:) = 0.0_JPRD F%RLAPIN(0) = 0.0_JPRD F%RLAPIN(-1) = 0.0_JPRD DO JN=1,R%NSMAX+2 F%RLAPIN(JN)=-(REAL(RA,JPRD)*REAL(RA,JPRD)/REAL(JN*(JN+1),JPRD)) ENDDO ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE PRE_SULEG END MODULE PRE_SULEG_MOD ectrans-1.8.0/src/trans/common/internal/cpledn_mod.F900000664000175000017500000000762615174631767023005 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE CPLEDN_MOD CONTAINS SUBROUTINE CPLEDN(KN,KODD,PFN,PX,KFLAG,PW,PXN,PXMOD) !**** *CPLEDN* - Routine to perform a single Newton iteration step to find ! the zero of the ordinary Legendre polynomial of degree N ! Purpose. ! -------- !** Interface. ! ---------- ! *CALL* *CPLEDN(KN,KDBLE,PX,KFLAG,PW,PXN,PXMOD)* ! Explicit arguments : ! -------------------- ! KN : Degree of the Legendre polynomial (in) ! KODD : odd or even number of latitudes (in) ! PFN : Fourier coefficients of series expansion (in) ! for the ordinary Legendre polynomials ! PX : abcissa where the computations are performed (in) ! KFLAG : When KFLAG.EQ.1 computes the weights (in) ! PW : Weight of the quadrature at PXN (out) ! PXN : new abscissa (Newton iteration) (out) ! PXMOD : PXN-PX (out) ! Implicit arguments : ! -------------------- ! None ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! None ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-10-15 ! Michel Rochas, 90-08-30 (Lobatto+cleaning) ! K. Yessad (Sep 2008): cleaning, improve comments. ! Nils Wedi + Mats Hamrud, 2009-02-05 revised following Swarztrauber, 2002 ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KN INTEGER(KIND=JPIM),INTENT(IN) :: KODD REAL(KIND=JPRD),INTENT(IN) :: PFN(0:KN/2) REAL(KIND=JPRD),INTENT(IN) :: PX INTEGER(KIND=JPIM),INTENT(IN) :: KFLAG REAL(KIND=JPRD),INTENT(OUT) :: PW REAL(KIND=JPRD),INTENT(INOUT) :: PXN REAL(KIND=JPRD),INTENT(OUT) :: PXMOD ! ------------------------------------------------------------------ REAL(KIND=JPRD) :: ZDLX,ZDLK,ZDLLDN,ZDLXN,ZDLMOD INTEGER(KIND=JPIM), PARAMETER :: JPKD=KIND(PX) INTEGER(KIND=JPIM) :: JN, IK ! ----------------------------------------------------------------- !* 1. NEWTON ITERATION STEP. ! ---------------------- ZDLX = PX ZDLK = 0.0_JPRD IF( KODD==0 ) ZDLK=0.5_JPRD*PFN(0) ZDLXN = 0.0_JPRD ZDLLDN = 0.0_JPRD IK=1 IF(KFLAG == 0)THEN DO JN=2-KODD,KN,2 ! normalised ordinary Legendre polynomial == \overbar{P_n}^0 ZDLK = ZDLK + PFN(IK)*COS(REAL(JN,JPKD)*ZDLX) ! normalised derivative == d/d\theta(\overbar{P_n}^0) ZDLLDN = ZDLLDN - PFN(IK)*REAL(JN,JPKD)*SIN(REAL(JN,JPKD)*ZDLX) IK=IK+1 ENDDO ! Newton method ZDLMOD = -ZDLK/ZDLLDN ZDLXN = ZDLX+ZDLMOD PXN = ZDLXN PXMOD = ZDLMOD ENDIF ! ------------------------------------------------------------------ !* 2. Computes weight. ! ---------------- IF(KFLAG == 1)THEN DO JN=2-KODD,KN,2 ! normalised derivative ZDLLDN = ZDLLDN - PFN(IK)*REAL(JN,JPKD)*SIN(REAL(JN,JPKD)*ZDLX) IK=IK+1 ENDDO PW = REAL(2*KN+1,JPKD)/ZDLLDN**2 ENDIF ! ------------------------------------------------------------------ END SUBROUTINE CPLEDN END MODULE CPLEDN_MOD ectrans-1.8.0/src/trans/common/internal/sumplat_mod.F900000664000175000017500000002045215174631767023215 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE SUMPLAT_MOD CONTAINS SUBROUTINE SUMPLAT(KDGL,KPROC,KPROCA,KMYSETA,LDSPLIT,LDEQ_REGIONS,& &KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& &KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,& &PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& &KMEDIAP,KRESTM,LDSPLITLAT,KMYPROC,KLOEN) !**** *SUMPLAT * - Initialize gridpoint distrbution in N-S direction ! Purpose. ! -------- !** Interface. ! ---------- ! *CALL* *SUMPLAT * ! Explicit arguments - input : ! -------------------- ! KDGL -last latitude ! KPROC -total number of processors ! KPROCA -number of processors in A direction ! KMYSETA -process number in A direction ! LDSPLIT -true for latitudes shared between sets ! LDEQ_REGIONS -true if eq_regions partitioning ! PWEIGHT -weight per grid-point if weighted distribution ! LDWEIGHTED_DISTR -true if weighted distribution ! Explicit arguments - output: ! -------------------- ! PMEDIAP -mean weight per PE if weighted distribution ! KMEDIAP -mean number of grid points per PE ! KPROCAGP -number of grid points per A set ! KRESTM -number of PEs with one extra point ! KFRSTLAT -first latitude row on processor ! KLSTLAT -last latitude row on processor ! KFRSTLOFF -offset for first latitude in set ! KPTRLAT -pointer to start of latitude ! KPTRFRSTLAT-pointer to first latitude ! KPTRLSTLAT -pointer to last latitude ! KPTRFLOFF -offset for pointer to first latitude ! LDSPLITLAT -true for latitudes which are split ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. SUMPLATB and SUEMPLATB. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! David Dent:97-06-02 parameters KFRSTLAT etc added ! JF. Estrade:97-11-13 Adaptation to ALADIN case ! J.Boutahar: 98-07-06 phasing with CY19 ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option + cleanings ! (correct computation of extrapolar latitudes for KPROCL). ! Modified 98-12-07 by K. YESSAD and C. FISCHER: cleaning. ! - merge old sumplat.F and suemplat.F ! - gather 'lelam' code and 'not lelam' code. ! - clean (useless duplication of variables, non doctor features). ! - remodularise according to lelam/not lelam ! -> lelam features in new routine suemplatb.F, ! not lelam features in new routine sumplatb.F ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM ,JPRD USE TPM_GEOMETRY ,ONLY : G USE SUMPLATB_MOD ,ONLY : SUMPLATB USE SUMPLATBEQ_MOD ,ONLY : SUMPLATBEQ USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE ! * DUMMY: REAL(KIND=JPRD),INTENT(OUT) :: PMEDIAP INTEGER(KIND=JPIM),INTENT(OUT) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(OUT) :: KRESTM INTEGER(KIND=JPIM),INTENT(IN) :: KDGL INTEGER(KIND=JPIM),INTENT(IN) :: KPROC INTEGER(KIND=JPIM),INTENT(IN) :: KPROCA INTEGER(KIND=JPIM),INTENT(IN) :: KMYSETA REAL(KIND=JPRD),INTENT(IN) :: PWEIGHT(:) LOGICAL,INTENT(INOUT) :: LDWEIGHTED_DISTR INTEGER(KIND=JPIM),INTENT(OUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KLSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KFRSTLOFF INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM),INTENT(OUT) :: KPTRFLOFF INTEGER(KIND=JPIM),INTENT(OUT) :: KPROCAGP(KPROCA) LOGICAL,INTENT(IN) :: LDSPLIT LOGICAL,INTENT(IN) :: LDEQ_REGIONS LOGICAL,INTENT(OUT) :: LDSPLITLAT(:) INTEGER(KIND=JPIM),INTENT(IN) :: KMYPROC INTEGER(KIND=JPIM),INTENT(IN) :: KLOEN(KDGL) ! * LOCAL: ! === END OF INTERFACE BLOCK === INTEGER(KIND=JPIM) :: INDIC(KPROCA),ILAST(KPROCA) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IPTRLATITUDE, JA, JGL LOGICAL :: LLFOURIER LOGICAL, PARAMETER :: LLDEBUG=.FALSE. ! ----------------------------------------------------------------- !* 1. CODE DEPENDING ON 'LELAM': COMPUTATION OF ! KMEDIAP, KRESTM, INDIC, ILAST. ! ----------------------------------------- INDIC(:)=0 ILAST(:)=0 IF(LDWEIGHTED_DISTR.AND..NOT.LDEQ_REGIONS)THEN CALL ABORT_TRANS ('SUMPLAT: LDWEIGHTED_DISTR=T AND LDEQ_REGIONS=F NOT SUPPORTED') ENDIF IF( LDEQ_REGIONS )THEN CALL SUMPLATBEQ(1,KDGL,KPROC,KPROCA,KLOEN,LDSPLIT,LDEQ_REGIONS,& &PWEIGHT,LDWEIGHTED_DISTR,PMEDIAP,KPROCAGP,& &KMEDIAP,KRESTM,INDIC,ILAST) ELSE LLFOURIER=.FALSE. CALL SUMPLATB(1,KDGL,KPROCA,KLOEN,LDSPLIT,LLFOURIER,& &KMEDIAP,KRESTM,INDIC,ILAST) ENDIF ! ----------------------------------------------------------------- !* 2. CODE NOT DEPENDING ON 'LELAM': COMPUTATION OF ! KFRSTLAT TO LDSPLITLAT. ! --------------------------------------------- ! * Computation of first and last latitude of processor sets ! ----------- in grid-point-space ----------------------- IF(KMYPROC==1.AND.LLDEBUG)THEN WRITE(0,'("")') WRITE(0,'("SUMPLAT_MOD:LDWEIGHTED_DISTR=",L1)')LDWEIGHTED_DISTR WRITE(0,'("")') DO JA=1,KPROCA WRITE(0,'("SUMPLAT_MOD: JA=",I5," ILAST=",I5," INDIC=",I5)')& &JA,ILAST(JA),INDIC(JA) ENDDO WRITE(0,'("")') IF( LDEQ_REGIONS .AND. LDSPLIT )THEN DO JA=1,KPROCA WRITE(0,'("SUMPLAT_MOD: JA=",I5," KPROCAGP=",I12)')& &JA,KPROCAGP(JA) ENDDO WRITE(0,'("")') ENDIF ENDIF KFRSTLAT(1) = 1 KLSTLAT(KPROCA) = KDGL DO JA=1,KPROCA-1 IF ((.NOT. LDSPLIT) .OR. INDIC(JA) == 0) THEN KFRSTLAT(JA+1) = ILAST(JA) + 1 KLSTLAT(JA) = ILAST(JA) ELSE KFRSTLAT(JA+1) = INDIC(JA) KLSTLAT(JA) = INDIC(JA) ENDIF ENDDO KFRSTLOFF=KFRSTLAT(KMYSETA)-1 ! * Initialise following data structures:- ! NPTRLAT (pointer to the start of each latitude) ! LSPLITLAT (TRUE if latitude is split over two A sets) ! NPTRFRSTLAT (pointer to the first latitude of each A set) ! NPTRLSTLAT (pointer to the last latitude of each A set) DO JGL=1,KDGL KPTRLAT (JGL)=-999 LDSPLITLAT(JGL)=.FALSE. ENDDO IPTRLATITUDE=0 DO JA=1,KPROCA DO JGL=KFRSTLAT(JA),KLSTLAT(JA) IPTRLATITUDE=IPTRLATITUDE+1 LDSPLITLAT(JGL)=.TRUE. IF( KPTRLAT(JGL) == -999 )THEN KPTRLAT(JGL)=IPTRLATITUDE LDSPLITLAT(JGL)=.FALSE. ENDIF ENDDO ENDDO DO JA=1,KPROCA IF( LDSPLITLAT(KFRSTLAT(JA)) .AND. JA /= 1)THEN KPTRFRSTLAT(JA)=KPTRLAT(KFRSTLAT(JA))+1 ELSE KPTRFRSTLAT(JA)=KPTRLAT(KFRSTLAT(JA)) ENDIF IF( LDSPLITLAT(KLSTLAT(JA)) .AND. JA == KPROCA)THEN KPTRLSTLAT(JA)=KPTRLAT(KLSTLAT(JA))+1 ELSE KPTRLSTLAT(JA)=KPTRLAT(KLSTLAT(JA)) ENDIF ENDDO KPTRFLOFF=KPTRFRSTLAT(KMYSETA)-1 IF(KMYPROC==1.AND.LLDEBUG)THEN DO JGL=1,KDGL WRITE(0,'("SUMPLAT_MOD: JGL=",I5," KPTRLAT=",I5," LDSPLITLAT=",L4)')& & JGL,KPTRLAT(JGL),LDSPLITLAT(JGL) ENDDO DO JA=1,KPROCA WRITE(0,'("SUMPLAT_MOD: JA=",I5," KFRSTLAT=",I5," KLSTLAT=",I5,& & " KPTRFRSTLAT=",I5," KPTRLSTLAT=",I5," KLSTLAT-KFRSTLAT=",I5,& & " SUM(G%NLOEN(KFRSTLAT:KLSTLAT))=",I10)')& & JA,KFRSTLAT(JA),KLSTLAT(JA),KPTRFRSTLAT(JA),KPTRLSTLAT(JA),& & KLSTLAT(JA)-KFRSTLAT(JA),SUM(G%NLOEN(KFRSTLAT(JA):KLSTLAT(JA))) ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SUMPLAT END MODULE SUMPLAT_MOD ectrans-1.8.0/src/trans/common/internal/ectrans_version_mod.F90.in0000664000175000017500000000256315174631767025344 0ustar alastairalastair! (C) Copyright 2023- ECMWF. ! ! 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. ! MODULE ECTRANS_VERSION_MOD IMPLICIT NONE CONTAINS FUNCTION ECTRANS_VERSION_STR() !**** *ECTRANS_VERSION_STR* - Return ecTrans version as a string CHARACTER(LEN=LEN("@ectrans_VERSION_STR@")) :: ECTRANS_VERSION_STR ECTRANS_VERSION_STR = "@ectrans_VERSION_STR@" END FUNCTION ECTRANS_VERSION_STR FUNCTION ECTRANS_VERSION_INT() !**** *ECTRANS_VERSION_INT* - Return ecTrans version as an integer USE EC_PARKIND ,ONLY : JPIM INTEGER(KIND=JPIM) :: ECTRANS_VERSION_INT ECTRANS_VERSION_INT = 10000_JPIM * @ectrans_VERSION_MAJOR@ & & + 100_JPIM * @ectrans_VERSION_MINOR@ & & + 10_JPIM * @ectrans_VERSION_PATCH@ END FUNCTION ECTRANS_VERSION_INT FUNCTION ECTRANS_GIT_SHA1() !**** *ECTRANS_GIT_SHA1* - Return the SHA-1 hash of the latest Git commit CHARACTER(LEN=LEN("@ectrans_GIT_SHA1@")) :: ECTRANS_GIT_SHA1 ECTRANS_GIT_SHA1 = "@ectrans_GIT_SHA1@" END FUNCTION ECTRANS_GIT_SHA1 END MODULE ECTRANS_VERSION_MOD ectrans-1.8.0/src/trans/common/internal/gawl_mod.F900000664000175000017500000000602715174631767022464 0ustar alastairalastair! (C) Copyright 1992- ECMWF. ! (C) Copyright 1992- 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. ! MODULE GAWL_MOD CONTAINS SUBROUTINE GAWL(PFN,PL,PW,PEPS,KN,KITER,PMOD) !**** *GAWL * - Routine to perform the Newton loop ! Purpose. ! -------- ! Find 0 of Legendre polynomial with Newton loop !** Interface. ! ---------- ! *CALL* *GAWL(PFN,PL,PW,PEPS,KN,KITER,PMOD) ! Explicit arguments : ! -------------------- ! PFN Fourier coefficients of series expansion ! for the ordinary Legendre polynomials (in) ! PL Gaussian latitude (inout) ! PW Gaussian weight (out) ! PEPS 0 of the machine (in) ! KN Truncation (in) ! KITER Number of iterations (out) ! PMOD Last modification (inout) ! Implicit arguments : ! -------------------- ! None ! Method. ! ------- ! Newton Loop. ! Externals. ! ---------- ! CPLEDN ! Reference. ! ---------- ! ARPEGE Documentation vol.2, ch3. ! Author. ! ------- ! Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 92-12-18 ! K. Yessad (Sep 2008): cleaning, improve comments. ! Nils Wedi + Mats Hamrud, 2009-02-05 revised following Swarztrauber, 2002 ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM USE CPLEDN_MOD ,ONLY : CPLEDN ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KN REAL(KIND=JPRD),INTENT(IN) :: PFN(0:KN/2) REAL(KIND=JPRD),INTENT(INOUT) :: PL REAL(KIND=JPRD),INTENT(OUT) :: PW REAL(KIND=JPRD),INTENT(IN) :: PEPS INTEGER(KIND=JPIM),INTENT(OUT) :: KITER REAL(KIND=JPRD),INTENT(INOUT) :: PMOD ! ------------------------------------------------------------------ INTEGER(KIND=JPIM) :: IFLAG, ITEMAX, JTER, IODD REAL(KIND=JPRD) :: ZW, ZX, ZXN ! ------------------------------------------------------------------ !* 1. Initialization. ! --------------- ITEMAX = 20 ZX = PL IFLAG = 0 IODD=MOD(KN,2) ! ------------------------------------------------------------------ !* 2. Newton iteration. ! ----------------- DO JTER=1,ITEMAX+1 KITER = JTER CALL CPLEDN(KN,IODD,PFN,ZX,IFLAG,ZW,ZXN,PMOD) ZX = ZXN IF(IFLAG == 1) EXIT IF(ABS(PMOD) <= PEPS*1000._JPRD) IFLAG = 1 ENDDO PL = ZXN PW = ZW ! ------------------------------------------------------------------ END SUBROUTINE GAWL END MODULE GAWL_MOD ectrans-1.8.0/src/trans/common/internal/myrecvset_mod.F900000664000175000017500000000346715174631767023560 0ustar alastairalastair! (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. ! MODULE MYRECVSET_MOD CONTAINS FUNCTION MYRECVSET(KSETS,KMYSET,KSET) !**** *MYRECVSET* RETURNS SET NUMBER TO SEND TO ! Purpose. ! -------- ! !** Interface. ! ---------- ! ISENDSET = MYRECVSET(KSETS,KMYSET,KSET) ! Explicit arguments : ! -------------------- ! input: KSETS ! Implicit arguments : NONE ! -------------------- ! Method. ! ------- ! ! Externals. ! ---------- ! NONE ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-03 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM) :: MYRECVSET INTEGER(KIND=JPIM),INTENT(IN) :: KSETS,KMYSET,KSET ! ------------------------------------------------------------------ !* 1. Check input argument for validity ! --------------------------------- IF(KSETS < 1 .OR. KMYSET > KSETS .OR. KSET > KSETS-1) THEN CALL ABORT_TRANS(' MYRECVSET: INVALID ARGUMENT ') ELSE !* 2. Compute output parameters ! ------------------------- MYRECVSET = MOD(-KSET-1+KMYSET+KSETS,KSETS)+1 ENDIF END FUNCTION MYRECVSET END MODULE MYRECVSET_MOD ectrans-1.8.0/src/trans/common/internal/sump_trans_preleg_mod.F900000664000175000017500000001100315174631767025251 0ustar alastairalastair! (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. ! MODULE SUMP_TRANS_PRELEG_MOD CONTAINS SUBROUTINE SUMP_TRANS_PRELEG ! Set up distributed environment for the transform package (part 1) USE EC_PARKIND ,ONLY : JPIM USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRW, NPRTRV, MYSETW USE SUWAVEDI_MOD ,ONLY : SUWAVEDI ! IMPLICIT NONE INTEGER(KIND=JPIM) :: JW,JV,JM,JMLOC,ILATPP,IRESTL,IMLOC,IDT,INM,ILAST INTEGER(KIND=JPIM) :: IMYMS(R%NSMAX+1),INUMTPP(NPRTRW) LOGICAL :: LLP1,LLP2 ! ------------------------------------------------------------------ IF(.NOT.D%LGRIDONLY) THEN LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUMP_TRANS_PRELEG ===' !* 1. Initialize partitioning of wave numbers to PEs ! ! ---------------------------------------------- ALLOCATE(D%NASM0(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NASM0 ',SIZE(D%NASM0 ),SHAPE(D%NASM0 ) ALLOCATE(D%NATM0(0:R%NTMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NATM0 ',SIZE(D%NATM0 ),SHAPE(D%NATM0 ) ALLOCATE(D%NUMPP(NPRTRW)) IF(LLP2)WRITE(NOUT,9) 'D%NUMPP ',SIZE(D%NUMPP ),SHAPE(D%NUMPP ) ALLOCATE(D%NPOSSP(NPRTRW+1)) IF(LLP2)WRITE(NOUT,9) 'D%NPOSSP',SIZE(D%NPOSSP ),SHAPE(D%NPOSSP ) ALLOCATE(D%NPROCM(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCM',SIZE(D%NPROCM ),SHAPE(D%NPROCM ) ALLOCATE(D%NPTRMS(NPRTRW)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRMS ',SIZE(D%NPTRMS ),SHAPE(D%NPTRMS ) ALLOCATE(D%NALLMS(R%NSMAX+1)) IF(LLP2)WRITE(NOUT,9) 'D%NALLMS ',SIZE(D%NALLMS ),SHAPE(D%NALLMS ) ALLOCATE(D%NDIM0G(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NDIM0G ',SIZE(D%NDIM0G ),SHAPE(D%NDIM0G ) CALL SUWAVEDI(R%NSMAX,R%NTMAX,NPRTRW,MYSETW,& &D%NASM0,D%NSPOLEGL,D%NPROCM,D%NUMPP,& &D%NSPEC,D%NSPEC2,D%NSPEC2MX,D%NPOSSP,IMYMS,& &D%NPTRMS,D%NALLMS,D%NDIM0G) CALL SUWAVEDI(R%NTMAX,R%NTMAX,NPRTRW,MYSETW,& &KASM0=D%NATM0,KUMPP=INUMTPP,KSPEC2=D%NTPEC2) D%NUMP = D%NUMPP (MYSETW) ALLOCATE(D%MYMS(D%NUMP)) IF(LLP2)WRITE(NOUT,9) 'D%MYMS ',SIZE(D%MYMS ),SHAPE(D%MYMS ) D%MYMS(:) = IMYMS(1:D%NUMP) D%NUMTP = INUMTPP(MYSETW) ALLOCATE(D%NLATLS(NPRTRW,NPRTRV)) IF(LLP2)WRITE(NOUT,9) 'D%NLATLS',SIZE(D%NLATLS ),SHAPE(D%NLATLS ) ALLOCATE(D%NLATLE(NPRTRW,NPRTRV)) IF(LLP2)WRITE(NOUT,9) 'D%NLATLE',SIZE(D%NLATLE ),SHAPE(D%NLATLE ) D%NLATLS(:,:) = 999999 D%NLATLE(:,:) = -1 ILATPP = R%NDGNH/NPRTRW IRESTL = R%NDGNH-NPRTRW*ILATPP DO JW=1,NPRTRW IF (JW > IRESTL) THEN D%NLATLS(JW,1) = IRESTL*(ILATPP+1)+(JW-IRESTL-1)*ILATPP+1 D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP-1 ELSE D%NLATLS(JW,1) = (JW-1)*(ILATPP+1)+1 D%NLATLE(JW,1) = D%NLATLS(JW,1)+ILATPP ENDIF ENDDO ILAST=0 DO JW=1,NPRTRW ILATPP = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)/NPRTRV IRESTL = (D%NLATLE(JW,1)-D%NLATLS(JW,1)+1)-NPRTRV*ILATPP DO JV=1,NPRTRV IF (JV > IRESTL) THEN D%NLATLS(JW,JV) = IRESTL*(ILATPP+1)+(JV-IRESTL-1)*ILATPP+1+ILAST D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP-1 ELSE D%NLATLS(JW,JV) = (JV-1)*(ILATPP+1)+1+ILAST D%NLATLE(JW,JV) = D%NLATLS(JW,JV)+ILATPP ENDIF ENDDO ILAST=D%NLATLE(JW,NPRTRV) ENDDO IF (LLP1) THEN DO JW=1,NPRTRW DO JV=1,NPRTRV WRITE(NOUT,'(" JW=",I6," JV=",I6," D%NLATLS=",I6," D%NLATLE=",I6)')& & JW,JV,D%NLATLS(JW,JV),D%NLATLE(JW,JV) ENDDO ENDDO ENDIF ALLOCATE(D%NPMT(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMT ',SIZE(D%NPMT ),SHAPE(D%NPMT ) ALLOCATE(D%NPMS(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMS ',SIZE(D%NPMS ),SHAPE(D%NPMS ) ALLOCATE(D%NPMG(0:R%NSMAX)) IF(LLP2)WRITE(NOUT,9) 'D%NPMG ',SIZE(D%NPMG ),SHAPE(D%NPMG ) IDT = R%NTMAX-R%NSMAX INM = 0 DO JMLOC=1,D%NUMP IMLOC = D%MYMS(JMLOC) D%NPMT(IMLOC) = INM D%NPMS(IMLOC) = INM+IDT INM = INM+R%NTMAX+2-IMLOC ENDDO INM = 0 DO JM=0,R%NSMAX D%NPMG(JM) = INM INM = INM+R%NTMAX+2-JM ENDDO D%NLEI3D = (R%NLEI3-1)/NPRTRW+1 ENDIF ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUMP_TRANS_PRELEG END MODULE SUMP_TRANS_PRELEG_MOD ectrans-1.8.0/src/trans/common/internal/sustaonl_mod.F900000664000175000017500000003156315174631767023405 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE SUSTAONL_MOD CONTAINS SUBROUTINE SUSTAONL(KMEDIAP,KRESTM,LDWEIGHTED_DISTR,PWEIGHT,PMEDIAP,KPROCAGP) !**** *SUSTAONL * - Routine to initialize parallel environment ! Purpose. ! -------- ! Initialize D%NSTA and D%NONL. ! Calculation of distribution of grid points to processors : ! Splitting of grid in B direction !** Interface. ! ---------- ! *CALL* *SUSTAONL * ! Explicit arguments : ! -------------------- ! KMEDIAP - mean number of grid points per PE ! KRESTM - number of PEs with one extra point ! LDWEIGHTED_DISTR -true if weighted distribution ! PWEIGHT -weight per grid-point if weighted distribution ! PMEDIAP -mean weight per PE if weighted distribution ! KPROCAGP -number of grid points per A set ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. NONE. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option. ! - removal of LRPOLE in YOMCT0. ! - removal of code under LRPOLE. ! Modified 98-12-04 C. Fischer: merge with SUESTAONL (Aladin) ! R. El Khatib 05-Apr-2007 Enable back vectorization on NEC ! R. El Khatib 30-Apr-2013 Optimization ! R. El Khatib 26-Apr-2018 vectorization ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM, JPRD USE MPL_MODULE ,ONLY : MPL_ALLGATHERV, MPL_RECV, MPL_SEND USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, MTAGPART, NPRCIDS, MYPROC, NPROC USE SET2PE_MOD ,ONLY : SET2PE USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE EQ_REGIONS_MOD ,ONLY : MY_REGION_NS, MY_REGION_EW, & & N_REGIONS, N_REGIONS_EW, N_REGIONS_NS ! IMPLICIT NONE ! DUMMY INTEGER(KIND=JPIM),INTENT(IN) :: KMEDIAP INTEGER(KIND=JPIM),INTENT(IN) :: KRESTM REAL(KIND=JPRD),INTENT(IN) :: PWEIGHT(:) LOGICAL,INTENT(IN) :: LDWEIGHTED_DISTR REAL(KIND=JPRD),INTENT(IN) :: PMEDIAP INTEGER(KIND=JPIM),INTENT(IN) :: KPROCAGP(:) ! LOCAL INTEGER(KIND=JPIM) :: IXPTLAT(R%NDGL), ILSTPTLAT(R%NDGL) INTEGER(KIND=JPIM) :: ICHK(R%NDLON,R%NDGL), ICOMBUF(R%NDGL*N_REGIONS_EW*2) INTEGER(KIND=JPIM) :: I1, I2, IBUFLEN, IDGLG, IDWIDE,& &IGL, IGL1, IGL2, IGLOFF, IGPTA, & &IGPTPRSETS, IGPTS, IGPTSP, ILEN, ILRECV, & &ILSEND, INPLAT, INXLAT, IPOS, & &IPROCB, IPTSRE, IRECV, & &IREST, ISEND, ITAG, JA, JB, JGL, JL, JNPTSRE, & &ILAT, ILON, ILOEN INTEGER(KIND=JPIM),ALLOCATABLE :: ICOMBUFG(:) REAL(KIND=JPRD),ALLOCATABLE :: ZWEIGHT(:,:) INTEGER(KIND=JPIM) :: JJ, ILENG(NPROC), IOFF(NPROC) LOGICAL :: LLABORT LOGICAL :: LLP1,LLP2 REAL(KIND=JPRD) :: ZDIVID(R%NDGL) REAL(KIND=JPRD) :: ZCOMP,ZPI INTEGER(KIND=JPIM) :: ILATMD,ILATMD1 ! ----------------------------------------------------------------- ZPI = 2.0_JPRD*ASIN(1.0_JPRD) IXPTLAT (:)=999999 ILSTPTLAT(:)=999999 LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IDWIDE = R%NDGL/2 IBUFLEN = R%NDGL*N_REGIONS_EW*2 IDGLG = R%NDGL I1 = MAX( 1,D%NFRSTLAT(MY_REGION_NS)-D%NFRSTLOFF) I2 = MIN(IDGLG,D%NLSTLAT (MY_REGION_NS)-D%NFRSTLOFF) ILEN = D%NLSTLAT(MY_REGION_NS) - D%NFRSTLAT(MY_REGION_NS)+1 IGPTPRSETS = SUM(G%NLOEN(1:D%NFRSTLAT(MY_REGION_NS)-1)) IF (D%LSPLIT) THEN IF( LEQ_REGIONS )THEN IGPTA=0 DO JA=1,MY_REGION_NS-1 IGPTA = IGPTA + KPROCAGP(JA) ENDDO IGPTS = KPROCAGP(MY_REGION_NS) ELSE IF (MY_REGION_NS <= KRESTM.OR.KRESTM == 0) THEN IGPTS = KMEDIAP IGPTA = KMEDIAP*(MY_REGION_NS-1) ELSE IGPTS = KMEDIAP-1 IGPTA = KMEDIAP*KRESTM+IGPTS*(MY_REGION_NS-1-KRESTM) ENDIF ENDIF ELSE IGPTA = IGPTPRSETS IGPTS = SUM(G%NLOEN(D%NFRSTLAT(MY_REGION_NS):D%NLSTLAT(MY_REGION_NS))) ENDIF IGPTSP = IGPTS/N_REGIONS(MY_REGION_NS) IREST = IGPTS-N_REGIONS(MY_REGION_NS)*IGPTSP IXPTLAT(1) = IGPTA-IGPTPRSETS+1 ILSTPTLAT(1) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)) INPLAT = G%NLOEN(D%NFRSTLAT(MY_REGION_NS))-IXPTLAT(1)+1 DO JGL=2,ILEN IXPTLAT(JGL) = 1 ILSTPTLAT(JGL) = G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) INPLAT = INPLAT+G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1) ENDDO ILSTPTLAT(ILEN) = G%NLOEN(D%NLSTLAT(MY_REGION_NS))-INPLAT+IGPTS DO JB=1,N_REGIONS_EW DO JGL=1,R%NDGL+N_REGIONS_NS-1 D%NSTA(JGL,JB) = 0 D%NONL(JGL,JB) = 0 ENDDO ENDDO ! grid point decomposition ! --------------------------------------- IF( NPROC > 1 )THEN DO JGL=1,ILEN ZDIVID(JGL) = 360000.0_JPRD/REAL(G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1),JPRD) ENDDO IF( LDWEIGHTED_DISTR )THEN ALLOCATE(ZWEIGHT(G%NLOEN(R%NDGL/2),R%NDGL)) IGL=0 DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) IGL=IGL+1 ZWEIGHT(JL,JGL)=PWEIGHT(IGL) ENDDO ENDDO ZCOMP=0 IGPTS=0 ENDIF DO JB=1,N_REGIONS(MY_REGION_NS) IF( .NOT.LDWEIGHTED_DISTR )THEN IF (JB <= IREST) THEN IPTSRE = IGPTSP+1 ELSE IPTSRE = IGPTSP ENDIF DO JNPTSRE=1,IPTSRE ILATMD = 360000 DO JGL=1,ILEN IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN ILATMD1 = NINT(REAL(IXPTLAT(JGL)-1,JPRD)*ZDIVID(JGL)) IF(ILATMD1 < ILATMD) THEN ILATMD = ILATMD1 INXLAT = JGL ENDIF ENDIF ENDDO IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN IGL=D%NPTRFLOFF+INXLAT IF (D%NSTA(IGL,JB) == 0) THEN D%NSTA(IGL,JB) = IXPTLAT(INXLAT) ENDIF D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 ENDIF IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 ENDDO ELSE DO WHILE ( (JB < N_REGIONS(MY_REGION_NS) .AND. ZCOMP < PMEDIAP) & & .OR. (JB == N_REGIONS(MY_REGION_NS) .AND. IGPTS < KPROCAGP(MY_REGION_NS)) ) IGPTS = IGPTS + 1 ILATMD = 360000 DO JGL=1,ILEN IF (IXPTLAT(JGL) <= ILSTPTLAT(JGL)) THEN ILATMD1 = NINT(REAL(IXPTLAT(JGL)-1,JPRD)*ZDIVID(JGL)) IF(ILATMD1 < ILATMD) THEN ILATMD = ILATMD1 INXLAT = JGL ENDIF ENDIF ENDDO IF (INXLAT >= I1 .AND. INXLAT <= I2) THEN IGL=D%NPTRFLOFF+INXLAT IF (D%NSTA(IGL,JB) == 0) THEN D%NSTA(IGL,JB) = IXPTLAT(INXLAT) ENDIF D%NONL(IGL,JB) = D%NONL(IGL,JB)+1 IF(IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1)THEN CALL ABORT_TRANS(' SUSTAONL: IGL<1.OR.IGL>R%NDGL+N_REGIONS_NS-1') ENDIF ILON=D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 ILAT=D%NFRSTLAT(MY_REGION_NS)+INXLAT-1 ILOEN=G%NLOEN(ILAT) IF(ILON<1.OR.ILON>ILOEN)THEN CALL ABORT_TRANS(' SUSTAONL: ILON<1.OR.ILON>ILOEN') ENDIF ZCOMP = ZCOMP + ZWEIGHT(ILON,ILAT) ENDIF IXPTLAT(INXLAT) = IXPTLAT(INXLAT)+1 ENDDO ZCOMP = ZCOMP - PMEDIAP ENDIF ENDDO IF( LDWEIGHTED_DISTR )THEN DEALLOCATE(ZWEIGHT) ENDIF ! Exchange local partitioning info to produce global view ! CALL GSTATS_BARRIER(795) CALL GSTATS(814,0) IF( LEQ_REGIONS )THEN ITAG = MTAGPART IPOS = 0 DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 IPOS = IPOS+1 ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,MY_REGION_EW) IPOS = IPOS+1 ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,MY_REGION_EW) ENDDO IF( IPOS > IBUFLEN )THEN CALL ABORT_TRANS(' SUSTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') ENDIF ILSEND = IPOS DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(IRECV,JA,JB,0,0) ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 ILENG(NPRCIDS(IRECV))=ILEN ENDDO ENDDO IOFF(1)=0 DO JJ=2,NPROC IOFF(JJ)=IOFF(JJ-1)+ILENG(JJ-1) ENDDO ALLOCATE(ICOMBUFG(SUM(ILENG(:)))) CALL MPL_ALLGATHERV(ICOMBUF(1:ILSEND),ICOMBUFG,ILENG,CDSTRING='SUSTAONL') DO JA=1,N_REGIONS_NS IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JB=1,N_REGIONS(JA) CALL SET2PE(IRECV,JA,JB,0,0) IF(IRECV /= MYPROC) THEN ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*2 IPOS = IOFF(NPRCIDS(IRECV)) DO JGL=IGL1,IGL2 IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 IPOS = IPOS+1 D%NSTA(IGL,JB) = ICOMBUFG(IPOS) IPOS = IPOS+1 D%NONL(IGL,JB) = ICOMBUFG(IPOS) ENDDO ENDIF ENDDO ENDDO DEALLOCATE(ICOMBUFG) ELSE ITAG = MTAGPART IPOS = 0 DO JB=1,N_REGIONS(MY_REGION_NS) DO JGL=1,D%NLSTLAT(MY_REGION_NS)-D%NFRSTLAT(MY_REGION_NS)+1 IPOS = IPOS+1 ICOMBUF(IPOS) = D%NSTA(D%NPTRFLOFF+JGL,JB) IPOS = IPOS+1 ICOMBUF(IPOS) = D%NONL(D%NPTRFLOFF+JGL,JB) ENDDO ENDDO IF( IPOS > IBUFLEN )THEN CALL ABORT_TRANS(' SUSTAONL: SEND BUFFER TOO SMALL FOR GLOBAL INFO') ENDIF ILSEND = IPOS DO JA=1,N_REGIONS_NS CALL SET2PE(ISEND,JA,MY_REGION_EW,0,0) IF(ISEND /= MYPROC) THEN CALL MPL_SEND(ICOMBUF(1:ILSEND),KDEST=NPRCIDS(ISEND),KTAG=ITAG, & & CDSTRING='SUSTAONL:') ENDIF ENDDO DO JA=1,N_REGIONS_NS CALL SET2PE(IRECV,JA,MY_REGION_EW,0,0) IF(IRECV /= MYPROC) THEN ILEN = (D%NLSTLAT(JA)-D%NFRSTLAT(JA)+1)*N_REGIONS(JA)*2 CALL MPL_RECV(ICOMBUF(1:ILEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, & & KOUNT=ILRECV,CDSTRING='SUSTAONL:') IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IPOS = 0 DO JB=1,N_REGIONS(JA) DO JGL=IGL1,IGL2 IGL = D%NPTRFRSTLAT(JA)+JGL-IGL1 IPOS = IPOS+1 D%NSTA(IGL,JB) = ICOMBUF(IPOS) IPOS = IPOS+1 D%NONL(IGL,JB) = ICOMBUF(IPOS) ENDDO ENDDO ENDIF ENDDO ENDIF CALL GSTATS(814,1) CALL GSTATS_BARRIER2(795) ELSE DO JGL=1,R%NDGL D%NSTA(JGL,1) = 1 D%NONL(JGL,1) = G%NLOEN(JGL) ENDDO ENDIF ! Confirm consistency of global partitioning, specifically testing for ! multiple assignments of same grid point and unassigned grid points LLABORT = .FALSE. DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) ICHK(JL,JGL) = 1 ENDDO ENDDO DO JA=1,N_REGIONS_NS IGLOFF = D%NPTRFRSTLAT(JA) DO JB=1,N_REGIONS(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JGL=IGL1,IGL2 IGL = IGLOFF+JGL-IGL1 DO JL=D%NSTA(IGL,JB),D%NSTA(IGL,JB)+D%NONL(IGL,JB)-1 IF( ICHK(JL,JGL) /= 1 )THEN WRITE(NOUT,'(" SUSTAONL : seta=",i4," setb=",i4,& &" row=",I4," sta=",I4," INVALID GRID POINT")')& &JA,JB,JGL,JL WRITE(0,'(" SUSTAONL : seta=",i4," setb=",i4,& &" ROW=",I4," sta=",I4," INVALID GRID POINT")')& &JA,JB,JGL,JL LLABORT = .TRUE. ENDIF ICHK(JL,JGL) = 2 ENDDO ENDDO ENDDO ENDDO DO JGL=1,R%NDGL DO JL=1,G%NLOEN(JGL) IF( ICHK(JL,JGL) /= 2 )THEN WRITE(NOUT,'(" SUSTAONL : row=",i4," sta=",i4,& &" GRID POINT NOT ASSIGNED")') JGL,JL LLABORT = .TRUE. ENDIF ENDDO ENDDO IF( LLABORT )THEN WRITE(NOUT,'(" SUSTAONL : inconsistent partitioning")') CALL ABORT_TRANS(' SUSTAONL: inconsistent partitioning') ENDIF IF (LLP1) THEN WRITE(UNIT=NOUT,FMT='('' OUTPUT FROM ROUTINE SUSTAONL '')') WRITE(UNIT=NOUT,FMT='('' '')') WRITE(UNIT=NOUT,FMT='('' PARTITIONING INFORMATION '')') WRITE(UNIT=NOUT,FMT='('' '')') IPROCB = MIN(32,N_REGIONS_EW) WRITE(UNIT=NOUT,FMT='(17X," SETB=",32(1X,I5))') (JB,JB=1,IPROCB) DO JA=1,N_REGIONS_NS IPROCB = MIN(32,N_REGIONS(JA)) WRITE(UNIT=NOUT,FMT='('' '')') IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) DO JGL=IGL1,IGL2 IGL=IGLOFF+JGL-IGL1 WRITE(UNIT=NOUT,FMT='(" SETA=",I5," LAT=",I5," NSTA=",& &32(1X,I5))') JA,JGL,(D%NSTA(IGL,JB),JB=1,IPROCB) WRITE(UNIT=NOUT,FMT='(" SETA=",I5," LAT=",I5," D%NONL=",& &32(1X,I5))') JA,JGL,(D%NONL(IGL,JB),JB=1,IPROCB) ENDDO WRITE(UNIT=NOUT,FMT='('' '')') ENDDO WRITE(UNIT=NOUT,FMT='('' '')') WRITE(UNIT=NOUT,FMT='('' '')') ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SUSTAONL END MODULE SUSTAONL_MOD ectrans-1.8.0/src/trans/common/internal/sutrle_mod.F900000775000175000017500000002144315174631767023052 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE SUTRLE_MOD CONTAINS SUBROUTINE SUTRLE(PNM,KGL,KLOOP) !**** *sutrle * - transposition of Legendre polynomials during set-up ! Purpose. ! -------- ! transposition of Legendre polynomials during set-up !** Interface. ! ---------- ! *call* *sutrle(pnm) ! Explicit arguments : ! -------------------- ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! P.Towers : 10-01-12 Corrected over allocation of ZSNDBUF (XT4 fix) ! G.Mozdzynski: March 2011 Support 2D (RW,RV) initialisation of legendre coeffs ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY: JPRD, JPIM USE MPL_MODULE, ONLY: MPL_ALLREDUCE, MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_NON_BLOCKING_STANDARD USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D, MTAGLETR, NPRCIDS, NPRTRW, NPRTRV, MYSETV, MYSETW, NPROC USE TPM_FIELDS, ONLY: F USE SET2PE_MOD, ONLY: SET2PE USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS ! IMPLICIT NONE REAL(KIND=JPRD),INTENT(IN) :: PNM(:) INTEGER(KIND=JPIM),INTENT(IN) :: KGL INTEGER(KIND=JPIM),INTENT(IN) :: KLOOP ! LOCAL REAL(KIND=JPRD), ALLOCATABLE :: ZSNDBUFV(:),ZRCVBUFV(:,:) REAL(KIND=JPRD), ALLOCATABLE :: ZSNDBUFW(:,:),ZRCVBUFW(:,:) INTEGER(KIND=JPIM) :: IM, IPOS, & & IRECVSET, IRECV, ISEND, ISENDSET, ITAG,ISENDSIZE, IRECVSIZE, & & J, JM, JMLOC, JN, JV, JROC ,IOFFT, IOFFG, IGL, ISREQ, IRREQ INTEGER(KIND=JPIM) :: ISENDREQ(MAX(NPRTRW,NPRTRV)) INTEGER(KIND=JPIM) :: IRECVREQ(MAX(NPRTRW,NPRTRV)) INTEGER(KIND=JPIM) :: IGLVS(NPRTRV) INTEGER(KIND=JPIM) :: IGLVR(NPRTRV) INTEGER(KIND=JPIM) :: IPOSW(NPRTRW) ! ------------------------------------------------------------------ !* 0. Some initializations. ! --------------------- ITAG = MTAGLETR+KLOOP ! Perform barrier synchronisation to guarantee all processors have ! completed all previous communication IF( NPROC > 1 .AND. KLOOP ==1)THEN CALL GSTATS(783,0) CALL MPL_BARRIER(CDSTRING='SUTRLE:') CALL GSTATS(783,1) ENDIF ! ! First do communications in NPRTRV direction ! !* Calculate send buffer size IF(KGL > 0) THEN ISENDSIZE = R%NSPOLEG+1 ELSE ISENDSIZE=1 ENDIF ALLOCATE (ZSNDBUFV(ISENDSIZE)) ALLOCATE (ZRCVBUFV(R%NSPOLEG+1,NPRTRV)) !* copy data to be sent into zsndbufv ZSNDBUFV(1) = KGL IF(KGL > 0) THEN CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(J) DO J=1,R%NSPOLEG ZSNDBUFV(J+1) = PNM(J) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1141,1) ENDIF IRREQ=0 DO JROC=1,NPRTRV-1 IRECV = MYSETV+JROC IF (IRECV > NPRTRV) IRECV = IRECV-NPRTRV IRECVSET = IRECV CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET) IRREQ = IRREQ+1 CALL GSTATS(801,0) CALL MPL_RECV(ZRCVBUFV(:,IRECVSET),KSOURCE=NPRCIDS(IRECV), & &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO ISREQ = 0 DO JROC=1,NPRTRV-1 ISEND = MYSETV-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRV ISENDSET = ISEND CALL SET2PE(ISEND,0,0,MYSETW,ISENDSET) ISREQ = ISREQ+1 CALL GSTATS(801,0) CALL MPL_SEND(ZSNDBUFV(1:ISENDSIZE),KDEST=NPRCIDS(ISEND), & &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO IF(ISREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF IF(IRREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF !* copy data from buffer to f%rpnm CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JROC,IRECV,IRECVSET,IGL,JMLOC,IM,IOFFT,IOFFG,JN) DO JROC=1,NPRTRV-1 IRECV = MYSETV+JROC IF (IRECV > NPRTRV) IRECV = IRECV-NPRTRV IRECVSET = IRECV CALL SET2PE(IRECV,0,0,MYSETW,IRECVSET) IGL = ZRCVBUFV(1,IRECVSET) IGLVS(IRECVSET)=IGL IF( IGL > 0 )THEN DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) IOFFT = D%NPMT(IM) IOFFG = D%NPMG(IM) DO JN=1,R%NTMAX-IM+2 F%RPNM(IGL,IOFFT+JN) = ZRCVBUFV(1+IOFFG+JN,IRECVSET) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DEALLOCATE (ZSNDBUFV) !* copy data from pnm to rpnm IGLVS(MYSETV)=KGL IF(KGL > 0) THEN ZRCVBUFV(1,MYSETV)=KGL ZRCVBUFV(2:R%NSPOLEG+1,MYSETV)=PNM(1:R%NSPOLEG) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JMLOC,IM,IOFFT,IOFFG,JN) DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) IOFFT = D%NPMT(IM) IOFFG = D%NPMG(IM) DO JN=1,R%NTMAX-IM+2 F%RPNM(KGL,IOFFT+JN) = PNM(IOFFG+JN) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1141,1) ! ! Now do communications in the NPRTRW direction ! !* Calculate send buffer size ISENDSIZE=0 DO JROC=1,NPRTRW-1 ISEND = MYSETW-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRW ISENDSET = ISEND CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) IPOS = 0 DO JM=0,R%NSMAX IF (ISENDSET == D%NPROCM(JM) ) IPOS = IPOS + R%NTMAX-JM+2 ENDDO ISENDSIZE = MAX(IPOS,ISENDSIZE) ENDDO ISENDSIZE=ISENDSIZE*NPRTRV+NPRTRV IRECVSIZE=ISENDSIZE IF( NPROC > 1 )THEN CALL GSTATS(801,0) CALL MPL_ALLREDUCE(IRECVSIZE,'MAX',CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDIF ALLOCATE (ZSNDBUFW(ISENDSIZE,NPRTRW)) ALLOCATE (ZRCVBUFW(IRECVSIZE,NPRTRW)) CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JROC,ISEND,ISENDSET,IPOS,JV,IGL,JM,JN) DO JROC=1,NPRTRW-1 ISEND = MYSETW-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRW ISENDSET = ISEND CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) !* copy data to be sent into zsndbufw IPOS=0 DO JV=1,NPRTRV IPOS=IPOS+1 ZSNDBUFW(IPOS,ISENDSET) = IGLVS(JV) ENDDO DO JV=1,NPRTRV IGL = IGLVS(JV) IF( IGL > 0 )THEN DO JM=0,R%NSMAX IF (ISENDSET == D%NPROCM(JM) ) THEN DO JN=1,R%NTMAX-JM+2 IPOS = IPOS + 1 ZSNDBUFW(IPOS,ISENDSET) = ZRCVBUFV(1+D%NPMG(JM)+JN,JV) ENDDO ENDIF ENDDO ENDIF ENDDO IPOSW(ISENDSET)=IPOS ENDDO !$OMP END PARALLEL DO CALL GSTATS(1141,1) IRREQ = 0 DO JROC=1,NPRTRW-1 IRECV = MYSETW+JROC IF (IRECV > NPRTRW) IRECV = IRECV-NPRTRW IRECVSET = IRECV CALL SET2PE(IRECV,0,0,IRECVSET,MYSETV) !* receive message (if not empty) IRREQ = IRREQ+1 CALL GSTATS(801,0) CALL MPL_RECV(ZRCVBUFW(:,IRECVSET),KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO ISREQ = 0 DO JROC=1,NPRTRW-1 ISEND = MYSETW-JROC IF (ISEND <= 0) ISEND = ISEND+NPRTRW ISENDSET = ISEND CALL SET2PE(ISEND,0,0,ISENDSET,MYSETV) ISENDSIZE = IPOSW(ISENDSET) ISREQ = ISREQ+1 CALL GSTATS(801,0) CALL MPL_SEND(ZSNDBUFW(1:ISENDSIZE,ISENDSET),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SUTRLE:') CALL GSTATS(801,1) ENDDO IF(ISREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF IF(IRREQ > 0) THEN CALL GSTATS(801,0) CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), & & CDSTRING='SUTRLE: WAIT') CALL GSTATS(801,1) ENDIF CALL GSTATS(1141,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JROC,IRECV,IRECVSET,IPOS,IGLVR,JV,IGL,JMLOC,IM,IOFFT,JN) DO JROC=1,NPRTRW-1 IRECV = MYSETW+JROC IF (IRECV > NPRTRW) IRECV = IRECV-NPRTRW IRECVSET = IRECV CALL SET2PE(IRECV,0,0,IRECVSET,MYSETV) !* copy data from buffer to f%rpnm IPOS=0 DO JV=1,NPRTRV IPOS=IPOS+1 IGLVR(JV)=ZRCVBUFW(IPOS,IRECVSET) ENDDO DO JV=1,NPRTRV IGL = IGLVR(JV) IF( IGL > 0 )THEN DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) IOFFT = D%NPMT(IM) DO JN=1,R%NTMAX-IM+2 IPOS = IPOS + 1 F%RPNM(IGL,IOFFT+JN) = ZRCVBUFW(IPOS,IRECVSET) ENDDO ENDDO ENDIF ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1141,1) DEALLOCATE (ZRCVBUFV) DEALLOCATE (ZSNDBUFW) DEALLOCATE (ZRCVBUFW) IF( NPROC > 1 .AND. KLOOP ==1)THEN CALL GSTATS(783,0) CALL MPL_BARRIER(CDSTRING='SUTRLE:') CALL GSTATS(783,1) ENDIF END SUBROUTINE SUTRLE END MODULE SUTRLE_MOD ectrans-1.8.0/src/trans/common/internal/setup_dims_mod.F900000664000175000017500000000224515174631767023704 0ustar alastairalastair! (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. ! MODULE SETUP_DIMS_MOD CONTAINS SUBROUTINE SETUP_DIMS ! EXPECTED TO BE SET ALREADY: ! - NSMAX ! - NTMAX ! - NDGL USE EC_PARKIND ,ONLY : JPIM USE TPM_DIM ,ONLY : R IMPLICIT NONE INTEGER(KIND=JPIM) :: JM,JN,ISPOLEG ! ------------------------------------------------------------------ ISPOLEG = 0 DO JM=0,R%NSMAX DO JN=JM,R%NTMAX+1 ISPOLEG = ISPOLEG+1 ENDDO ENDDO R%NSPOLEG = ISPOLEG R%NSPEC_G = (R%NSMAX+1)*(R%NSMAX+2)/2 R%NSPEC2_G = R%NSPEC_G*2 R%NDGNH = (R%NDGL+1)/2 R%NLEI1 = R%NSMAX+4+MOD(R%NSMAX+4+1,2) R%NLEI3 = R%NDGNH+MOD(R%NDGNH+2,2) R%NLED3 = R%NTMAX+2+MOD(R%NTMAX+3,2) R%NLED4 = R%NTMAX+3+MOD(R%NTMAX+4,2) ! ------------------------------------------------------------------ END SUBROUTINE SETUP_DIMS END MODULE SETUP_DIMS_MOD ectrans-1.8.0/src/trans/common/internal/ectrans_blas_mod.F900000664000175000017500000003027715174631767024176 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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. ! !==================================================================== MODULE ECTRANS_BLAS_MOD !==================================================================== ! Author: Willem Deconinck (ECMWF) ! ! This module provides interfaces for BLAS routines such as ! DGEMM/SGEMM and DGEMV/SGEMV ! The correct overload is used depending on the precision of the arguments !==================================================================== USE EC_PARKIND, ONLY : JPRD, JPRM, JPIM IMPLICIT NONE PRIVATE PUBLIC :: GEMM, GEMV !--------------------------------------------------------------------- INTERFACE GEMM ! GEMM performs one of the matrix-matrix operations ! ! C := alpha*op( A )*op( B ) + beta*C, ! ! where op( X ) is one of ! ! op( X ) = X or op( X ) = X**T, ! ! alpha and beta are scalars, and A, B and C are matrices, with op( A ) ! an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. ! SGEMM MODULE PROCEDURE GEMM_SP ! Matrix arguments as array, (alpha,beta) in SP MODULE PROCEDURE GEMM_SP_DP ! Matrix arguments as array, (alpha,beta) in DP MODULE PROCEDURE GEMM_SCAL_SP ! Matrix arguments as scalar (address), (alpha,beta) in SP MODULE PROCEDURE GEMM_SCAL_SP_DP ! Matrix arguments as scalar (address), (alpha,beta) in DP ! DGEMM MODULE PROCEDURE GEMM_DP ! Matrix arguments as array, (alpha,beta) in DP MODULE PROCEDURE GEMM_DP_SP ! Matrix arguments as array, (alpha,beta) in SP MODULE PROCEDURE GEMM_SCAL_DP ! Matrix arguments as scalar (address), (alpha,beta) in DP MODULE PROCEDURE GEMM_SCAL_DP_SP ! Matrix arguments as scalar (address), (alpha,beta) in SP END INTERFACE !--------------------------------------------------------------------- INTERFACE GEMV ! GEMV performs one of the matrix-vector operations ! ! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, ! ! where alpha and beta are scalars, x and y are vectors and A is an ! m by n matrix. ! SGEMV MODULE PROCEDURE GEMV_SP ! Matrix/Vector arguments as array, (alpha,beta) in SP MODULE PROCEDURE GEMV_SP_DP ! Matrix/Vector arguments as array, (alpha,beta) in DP MODULE PROCEDURE GEMV_SCAL_SP ! Matrix/Vector arguments as scalar (address), (alpha,beta) in SP MODULE PROCEDURE GEMV_SCAL_SP_DP ! Matrix/Vector arguments as scalar (address), (alpha,beta) in DP ! DGEMV MODULE PROCEDURE GEMV_DP ! Matrix/Vector arguments as array, (alpha,beta) in DP MODULE PROCEDURE GEMV_DP_SP ! Matrix/Vector arguments as array, (alpha,beta) in SP MODULE PROCEDURE GEMV_SCAL_DP ! Matrix/Vector arguments as scalar (address), (alpha,beta) in DP MODULE PROCEDURE GEMV_SCAL_DP_SP ! Matrix/Vector arguments as scalar (address), (alpha,beta) in SP END INTERFACE !--------------------------------------------------------------------- !==================================================================== CONTAINS !==================================================================== SUBROUTINE GEMM_SCAL_DP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRD) ,INTENT(IN) :: A, B REAL(KIND=JPRD) ,INTENT(INOUT) :: C CALL DGEMM(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) END SUBROUTINE GEMM_SCAL_DP !--------------------------------------------------------------------- SUBROUTINE GEMM_SCAL_DP_SP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRD) ,INTENT(IN) :: A, B REAL(KIND=JPRD) ,INTENT(INOUT) :: C CALL GEMM_SCAL_DP(TRANSA, TRANSB, M, N, K, REAL(ALPHA,JPRD), A, LDA, B, LDB, REAL(BETA,JPRD), C, LDC) END SUBROUTINE GEMM_SCAL_DP_SP !--------------------------------------------------------------------- SUBROUTINE GEMM_DP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRD) ,INTENT(IN) :: A(LDA,*), B(LDB,*) REAL(KIND=JPRD) ,INTENT(INOUT) :: C(LDC,*) CALL GEMM_SCAL_DP(TRANSA, TRANSB, M, N, K, ALPHA, A(1,1), LDA, B(1,1), LDB, BETA, C(1,1), LDC) END SUBROUTINE GEMM_DP !--------------------------------------------------------------------- SUBROUTINE GEMM_DP_SP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRD) ,INTENT(IN) :: A(LDA,*), B(LDB,*) REAL(KIND=JPRD) ,INTENT(INOUT) :: C(LDC,*) CALL GEMM_SCAL_DP(TRANSA, TRANSB, M, N, K, REAL(ALPHA,JPRD), A(1,1), LDA, B(1,1), LDB, REAL(BETA,JPRD), C(1,1), LDC) END SUBROUTINE GEMM_DP_SP !--------------------------------------------------------------------- SUBROUTINE GEMM_SCAL_SP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) USE, INTRINSIC :: IEEE_EXCEPTIONS, ONLY : IEEE_GET_HALTING_MODE, IEEE_SET_HALTING_MODE, IEEE_INVALID REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRM) ,INTENT(IN) :: A, B REAL(KIND=JPRM) ,INTENT(INOUT) :: C #ifdef WITH_IEEE_HALT LOGICAL, PARAMETER :: LL_IEEE_HALT = .TRUE. #else LOGICAL, PARAMETER :: LL_IEEE_HALT = .FALSE. #endif LOGICAL :: LL_HALT_INVALID IF (LL_IEEE_HALT) THEN CALL IEEE_GET_HALTING_MODE(IEEE_INVALID,LL_HALT_INVALID) IF (LL_HALT_INVALID) CALL IEEE_SET_HALTING_MODE(IEEE_INVALID, .FALSE.) ENDIF CALL SGEMM(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) IF (LL_IEEE_HALT .AND. LL_HALT_INVALID) CALL IEEE_SET_HALTING_MODE(IEEE_INVALID, .TRUE.) END SUBROUTINE GEMM_SCAL_SP !--------------------------------------------------------------------- SUBROUTINE GEMM_SCAL_SP_DP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRM) ,INTENT(IN) :: A, B REAL(KIND=JPRM) ,INTENT(INOUT) :: C CALL GEMM_SCAL_SP(TRANSA, TRANSB, M, N, K, REAL(ALPHA,JPRM), A, LDA, B, LDB, REAL(BETA,JPRM), C, LDC) END SUBROUTINE GEMM_SCAL_SP_DP !--------------------------------------------------------------------- SUBROUTINE GEMM_SP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRM) ,INTENT(IN) :: A(LDA,*), B(LDB,*) REAL(KIND=JPRM) ,INTENT(INOUT) :: C(LDC,*) CALL GEMM_SCAL_SP(TRANSA, TRANSB, M, N, K, ALPHA, A(1,1), LDA, B(1,1), LDB, BETA, C(1,1), LDC) END SUBROUTINE GEMM_SP !--------------------------------------------------------------------- SUBROUTINE GEMM_SP_DP(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: K, LDA, LDB, LDC, M, N CHARACTER ,INTENT(IN) :: TRANSA, TRANSB REAL(KIND=JPRM) ,INTENT(IN) :: A(LDA,*), B(LDB,*) REAL(KIND=JPRM) ,INTENT(INOUT) :: C(LDC,*) CALL GEMM_SCAL_SP(TRANSA, TRANSB, M, N, K, REAL(ALPHA,JPRM), A(1,1), LDA, B(1,1), LDB, REAL(BETA,JPRM), C(1,1), LDC) END SUBROUTINE GEMM_SP_DP !--------------------------------------------------------------------- SUBROUTINE GEMV_SCAL_SP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRM) ,INTENT(IN) :: A, X REAL(KIND=JPRM) ,INTENT(INOUT) :: Y CALL SGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) END SUBROUTINE GEMV_SCAL_SP !--------------------------------------------------------------------- SUBROUTINE GEMV_SCAL_SP_DP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRM) ,INTENT(IN) :: A, X REAL(KIND=JPRM) ,INTENT(INOUT) :: Y CALL GEMV_SCAL_SP(TRANS, M, N, REAL(ALPHA,JPRM), A, LDA, X, INCX, REAL(BETA,JPRM), Y, INCY) END SUBROUTINE GEMV_SCAL_SP_DP !--------------------------------------------------------------------- SUBROUTINE GEMV_SP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRM) ,INTENT(IN) :: A(:,:), X(:) REAL(KIND=JPRM) ,INTENT(INOUT) :: Y(:) CALL GEMV_SCAL_SP(TRANS, M, N, ALPHA, A(1,1), LDA, X(1), INCX, BETA, Y(1), INCY) END SUBROUTINE GEMV_SP !--------------------------------------------------------------------- SUBROUTINE GEMV_SP_DP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRM) ,INTENT(IN) :: A(:,:), X(:) REAL(KIND=JPRM) ,INTENT(INOUT) :: Y(:) CALL GEMV_SCAL_SP(TRANS, M, N, REAL(ALPHA,JPRM), A(1,1), LDA, X(1), INCX, REAL(BETA,JPRM), Y(1), INCY) END SUBROUTINE GEMV_SP_DP !--------------------------------------------------------------------- SUBROUTINE GEMV_SCAL_DP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRD) ,INTENT(IN) :: A, X REAL(KIND=JPRD) ,INTENT(INOUT) :: Y CALL DGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) END SUBROUTINE GEMV_SCAL_DP !--------------------------------------------------------------------- SUBROUTINE GEMV_SCAL_DP_SP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRD) ,INTENT(IN) :: A, X REAL(KIND=JPRD) ,INTENT(INOUT) :: Y CALL GEMV_SCAL_DP(TRANS, M, N, REAL(ALPHA,JPRD), A, LDA, X, INCX, REAL(BETA,JPRD), Y, INCY) END SUBROUTINE GEMV_SCAL_DP_SP !--------------------------------------------------------------------- SUBROUTINE GEMV_DP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRD) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRD) ,INTENT(IN) :: A(:,:), X(:) REAL(KIND=JPRD) ,INTENT(INOUT) :: Y(:) CALL GEMV_SCAL_DP(TRANS, M, N, ALPHA, A(1,1), LDA, X(1), INCX, BETA, Y(1), INCY) END SUBROUTINE GEMV_DP !--------------------------------------------------------------------- SUBROUTINE GEMV_DP_SP(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY) REAL(KIND=JPRM) ,INTENT(IN) :: ALPHA, BETA INTEGER(KIND=JPIM) ,INTENT(IN) :: LDA, INCX, INCY, M, N CHARACTER ,INTENT(IN) :: TRANS REAL(KIND=JPRD) ,INTENT(IN) :: A(:,:), X(:) REAL(KIND=JPRD) ,INTENT(INOUT) :: Y(:) CALL GEMV_SCAL_DP(TRANS, M, N, REAL(ALPHA,JPRD), A(1,1), LDA, X(1), INCX, REAL(BETA,JPRD), Y(1), INCY) END SUBROUTINE GEMV_DP_SP !==================================================================== END MODULE ECTRANS_BLAS_MOD ectrans-1.8.0/src/trans/common/internal/tpm_gen.F900000664000175000017500000000421515174631767022321 0ustar alastairalastair! (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. ! MODULE TPM_GEN ! Module for general control variables. USE EC_PARKIND ,ONLY : JPIM IMPLICIT NONE SAVE INTEGER(KIND=JPIM) :: NOUT ! Unit number for "standard" output INTEGER(KIND=JPIM) :: NERR ! Unit number for error messages INTEGER(KIND=JPIM) :: NPRINTLEV ! Printing level, 0=no print, 1=standard,2=debug INTEGER(KIND=JPIM) :: MSETUP0 = 0 ! Control of setup calls INTEGER(KIND=JPIM) :: NMAX_RESOL = 0 ! Maximum allowed number of resolutions INTEGER(KIND=JPIM) :: NCUR_RESOL = 0 ! Current resolution INTEGER(KIND=JPIM) :: NDEF_RESOL = 0 ! Number of defined resolutions INTEGER(KIND=JPIM) :: NPROMATR ! Packet size for transform (in no of fields) ! NPROMATR=0 means do all fields together (dflt) LOGICAL :: LALLOPERM ! Allocate some shared data structures permanently LOGICAL :: LMPOFF ! true: switch off message passing LOGICAL :: LSYNC_TRANS ! true: activate barriers in trmtol and trltom ! Use of synchronization/blocking in Transpose (some networks do get flooded) ! 0 = Post IRECVs up-front, use ISENDs, use WAITANY to recv data (default) ! 1 = Use ISENDs, use blocking RECVs, add barrier at the end of each cycle ! 2 = Use buffered SENDs, use blocking RECVs, add barrier at the end of each cycle INTEGER(KIND=JPIM) :: NTRANS_SYNC_LEVEL ! NSTACK_MEMORY_TR : optional memory strategy in gridpoint transpositions ! = 0 : prefer heap (slower but less memory consuming) ! > 0 : prefer stack (faster but more memory consuming) INTEGER(KIND=JPIM) :: NSTACK_MEMORY_TR = 0 LOGICAL, ALLOCATABLE :: LENABLED(:) ! true: the resolution is enabled (it has been ! initialised and has not been released afterward) END MODULE TPM_GEN ectrans-1.8.0/src/trans/common/internal/tpm_fields.F900000775000175000017500000000305415174631767023021 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TPM_FIELDS USE EC_PARKIND, ONLY: JPIM, JPRD IMPLICIT NONE SAVE TYPE FIELDS_TYPE REAL(KIND=JPRD) ,ALLOCATABLE :: RPNM(:,:) ! Legendre polynomials REAL(KIND=JPRD) ,ALLOCATABLE :: RMU(:) ! sin(theta) for Gaussian latitudes REAL(KIND=JPRD) ,ALLOCATABLE :: RW(:) ! Weights of the Gaussian quadrature REAL(KIND=JPRD) ,ALLOCATABLE :: R1MU2(:) ! 1.-MU*MU, cos(theta)**2 REAL(KIND=JPRD) ,ALLOCATABLE :: RACTHE(:) ! 1./SQRT(R1MU2), 1/(cos(theta)) REAL(KIND=JPRD) ,ALLOCATABLE :: REPSNM(:) ! eps(n,m) used in the Legendre transforms REAL(KIND=JPRD) ,ALLOCATABLE :: RN(:) ! n (to avoid integer to real conversion) REAL(KIND=JPRD) ,ALLOCATABLE :: RLAPIN(:) ! eigen-values of the inverse Laplace operator INTEGER(KIND=JPIM) ,ALLOCATABLE :: NLTN(:) ! R%NTMAX+2-JN REAL(KIND=JPRD) ,ALLOCATABLE :: RMU2(:) ! sin(theta) for dual input/output latitudes REAL(KIND=JPRD) ,ALLOCATABLE :: RACTHE2(:)! 1./SQRT(R1MU2), 1/(cos(theta)) dual input/output latitudes END TYPE FIELDS_TYPE TYPE(FIELDS_TYPE),ALLOCATABLE,TARGET :: FIELDS_RESOL(:) TYPE(FIELDS_TYPE),POINTER :: F END MODULE TPM_FIELDS ectrans-1.8.0/src/trans/common/internal/tpm_constants.F900000664000175000017500000000105515174631767023563 0ustar alastairalastair! (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. ! MODULE TPM_CONSTANTS USE EC_PARKIND ,ONLY : JPRD IMPLICIT NONE SAVE REAL(KIND=JPRD) :: RA ! Radius of Earth END MODULE TPM_CONSTANTS ectrans-1.8.0/src/trans/common/internal/pe2set_mod.F900000664000175000017500000000662115174631767022734 0ustar alastairalastair! (C) Copyright 1998- ECMWF. ! (C) Copyright 1998- 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. ! MODULE PE2SET_MOD CONTAINS SUBROUTINE PE2SET(KPE,KPRGPNS,KPRGPEW,KPRTRW,KPRTRV) !**** *PE2SET* - Convert from PE number to set numbers ! Purpose. ! -------- ! Convert from PE number to set numbers in both ! grid-point space and spectral space !** Interface. ! ---------- ! *CALL* *PE2SET(KPE,KPRGPNS,KPRGPEW,KPRTRW,KPRTRV) ! Explicit arguments : ! -------------------- ! input: KPE - integer processor number ! in the range 1 .. NPROC ! output: KPRGPNS - integer A set number in grid space ! in the range 1 .. NPRGPNS ! KPRGPEW - integer B set number in grid space ! in the range 1 .. NPRGPEW ! KPRTRW - integer A set number in spectral space ! in the range 1 .. NPRTRW ! KPRTRV - integer B set number in spectral space ! in the range 1 .. NPRTRV ! Implicit arguments : YOMMP parameters ! NPRGPNS,NPRGPEW,NPRTRW,NPRTRV,NPROC ! -------------------- ! Method. ! ------- ! PE allocation order is row oriented (e.g. NPRGPNS or NPRTRW = 4): ! 1 2 3 4 ! 5 6 7 8 ! 9 10 11 12 ! 13 14 15 16 ! . . . . ! Externals. ! ---------- ! NONE ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! David Dent *ECMWF* ! Modifications. ! -------------- ! Original : 98-08-19 ! Revision : 98-10-13 row ordering ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM USE TPM_DISTR ,ONLY : LEQ_REGIONS, NPRGPEW, NPROC, NPRTRV USE EQ_REGIONS_MOD ,ONLY : N_REGIONS, N_REGIONS_NS USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KPE INTEGER(KIND=JPIM),INTENT(OUT) :: KPRGPNS,KPRGPEW,KPRTRW,KPRTRV INTEGER(KIND=JPIM) :: IPE,JA ! ------------------------------------------------------------------ !* 1. Check input argument for validity ! --------------------------------- IF(KPE <= 0.OR.KPE > NPROC) THEN WRITE(*,'(A,2I8)') ' PE2SET INVALID ARGUMENT ',KPE,NPROC CALL ABORT_TRANS(' PE2SET INVALID ARGUMENT ') ELSE !* 2. Compute output parameters ! ------------------------- IF( LEQ_REGIONS )THEN KPRGPNS=1 IPE=KPE DO JA=1,N_REGIONS_NS IF( IPE > N_REGIONS(JA) )THEN IPE=IPE-N_REGIONS(JA) KPRGPNS=KPRGPNS+1 CYCLE ENDIF KPRGPEW=IPE EXIT ENDDO ELSE KPRGPEW=MOD(KPE-1,NPRGPEW)+1 KPRGPNS=(KPE-1)/NPRGPEW+1 ENDIF KPRTRV =MOD(KPE-1,NPRTRV)+1 KPRTRW =(KPE-1)/NPRTRV+1 ENDIF END SUBROUTINE PE2SET END MODULE PE2SET_MOD ectrans-1.8.0/src/trans/common/internal/eq_regions_mod.F900000664000175000017500000003406615174631767023671 0ustar alastairalastair! (C) Copyright 2006- ECMWF. ! (C) Copyright 2006- 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. ! MODULE eq_regions_mod ! ! Purpose. ! -------- ! eq_regions_mod provides the code to perform a high level ! partitioning of the surface of a sphere into regions of ! equal area and small diameter. ! the type. ! ! Background. ! ----------- ! This Fortran version of eq_regions is a much cut down version of the ! "Recursive Zonal Equal Area (EQ) Sphere Partitioning Toolbox" of the ! same name developed by Paul Leopardi at the University of New South Wales. ! This version has been coded specifically for the case of partitioning the ! surface of a sphere or S^dim (where dim=2) as denoted in the original code. ! Only a subset of the original eq_regions package has been coded to determine ! the high level distribution of regions on a sphere, as the detailed ! distribution of grid points to each region is left to IFS software. ! This is required to take into account the spatial distribution of grid ! points in an IFS gaussian grid and provide an optimal (i.e. exact) ! distribution of grid points over regions. ! ! The following copyright notice for the eq_regions package is included from ! the original MatLab release. ! ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! + Release 1.10 2005-06-26 + ! + + ! + Copyright (c) 2004, 2005, University of New South Wales + ! + + ! + Permission is hereby granted, free of charge, to any person obtaining + ! + a copy of this software and associated documentation files (the + ! + "Software"), to deal in the Software without restriction, including + ! + without limitation the rights to use, copy, modify, merge, publish, + ! + distribute, sublicense, and/or sell copies of the Software, and to + ! + permit persons to whom the Software is furnished to do so, subject to + ! + the following conditions: + ! + + ! + The above copyright notice and this permission notice shall be included + ! + in all copies or substantial portions of the Software. + ! + + ! + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + ! + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + ! + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + ! + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + ! + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + ! + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + ! + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + ! + + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! ! Modifications. ! -------------- ! Original : 2006-04-15 ! !-------------------------------------------------------------------------------- ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE SAVE PRIVATE PUBLIC eq_regions,l_regions_debug,n_regions_ns,n_regions_ew,n_regions,my_region_ns,my_region_ew PUBLIC eq_regions_t, eq_regions_save, eq_regions_load, eq_regions_free real(kind=jprd) :: pi type eq_regions_t logical :: l_regions_debug=.false. integer(kind=jpim) :: n_regions_ns integer(kind=jpim) :: n_regions_ew integer(kind=jpim) :: my_region_ns integer(kind=jpim) :: my_region_ew integer(kind=jpim),pointer :: n_regions(:) => null () end type eq_regions_t logical :: l_regions_debug=.false. integer(kind=jpim) :: n_regions_ns integer(kind=jpim) :: n_regions_ew integer(kind=jpim) :: my_region_ns integer(kind=jpim) :: my_region_ew integer(kind=jpim),pointer :: n_regions(:) => null () CONTAINS subroutine eq_regions_save (yder) type (eq_regions_t), intent (inout) :: yder yder%l_regions_debug = l_regions_debug yder%n_regions_ns = n_regions_ns yder%n_regions_ew = n_regions_ew yder%my_region_ns = my_region_ns yder%my_region_ew = my_region_ew yder%n_regions => n_regions nullify (n_regions) end subroutine subroutine eq_regions_load (yder) type (eq_regions_t), intent (inout) :: yder l_regions_debug = yder%l_regions_debug n_regions_ns = yder%n_regions_ns n_regions_ew = yder%n_regions_ew my_region_ns = yder%my_region_ns my_region_ew = yder%my_region_ew n_regions => yder%n_regions nullify (yder%n_regions) end subroutine subroutine eq_regions_free (yder) type (eq_regions_t), intent (inout) :: yder if (associated (yder%n_regions)) then deallocate (yder%n_regions) nullify (yder%n_regions) endif end subroutine subroutine eq_regions(N) ! ! eq_regions uses the zonal equal area sphere partitioning algorithm to partition ! the surface of a sphere into N regions of equal area and small diameter. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE integer(kind=jpim),intent(in) :: N integer(kind=jpim) :: n_collars,j real(kind=jprd),allocatable :: r_regions(:) real(kind=jprd) :: c_polar pi=2.0_jprd*asin(1.0_jprd) n_regions(:)=0 if( N == 1 )then ! ! We have only one region, which must be the whole sphere. ! n_regions(1)=1 n_regions_ns=1 else ! ! Given N, determine c_polar ! the colatitude of the North polar spherical cap. ! c_polar = polar_colat(N) ! ! Given N, determine the ideal angle for spherical collars. ! Based on N, this ideal angle, and c_polar, ! determine n_collars, the number of collars between the polar caps. ! n_collars = num_collars(N,c_polar,ideal_collar_angle(N)) n_regions_ns=n_collars+2 ! ! Given N, c_polar and n_collars, determine r_regions, ! a list of the ideal real number of regions in each collar, ! plus the polar caps. ! The number of elements is n_collars+2. ! r_regions[1] is 1. ! r_regions[n_collars+2] is 1. ! The sum of r_regions is N. allocate(r_regions(n_collars+2)) call ideal_region_list(N,c_polar,n_collars,r_regions) ! ! Given N and r_regions, determine n_regions, a list of the natural number ! of regions in each collar and the polar caps. ! This list is as close as possible to r_regions. ! The number of elements is n_collars+2. ! n_regions[1] is 1. ! n_regions[n_collars+2] is 1. ! The sum of n_regions is N. ! call round_to_naturals(N,n_collars,r_regions) deallocate(r_regions) if( N /= sum(n_regions(:)) )then write(*,'("eq_regions: N=",I10," sum(n_regions(:))=",I10)')N,sum(n_regions(:)) call abor1('eq_regions: N /= sum(n_regions)') endif endif if( l_regions_debug )then write(*,'("eq_regions: N=",I6," n_regions_ns=",I4)') N,n_regions_ns do j=1,n_regions_ns write(*,'("eq_regions: n_regions(",I4,")=",I4)') j,n_regions(j) enddo endif n_regions_ew=maxval(n_regions(:)) return end subroutine eq_regions function num_collars(N,c_polar,a_ideal) result(num_c) ! !NUM_COLLARS The number of collars between the polar caps ! ! Given N, an ideal angle, and c_polar, ! determine n_collars, the number of collars between the polar caps. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE integer(kind=jpim),intent(in) :: N real(kind=jprd),intent(in) :: a_ideal,c_polar integer(kind=jpim) :: num_c logical :: enough enough = (N > 2) .and. (a_ideal > 0) if( enough )then num_c = max(1,nint((pi-2.*c_polar)/a_ideal)) else num_c = 0 endif return end function num_collars subroutine ideal_region_list(N,c_polar,n_collars,r_regions) ! !IDEAL_REGION_LIST The ideal real number of regions in each zone ! ! List the ideal real number of regions in each collar, plus the polar caps. ! ! Given N, c_polar and n_collars, determine r_regions, a list of the ideal real ! number of regions in each collar, plus the polar caps. ! The number of elements is n_collars+2. ! r_regions[1] is 1. ! r_regions[n_collars+2] is 1. ! The sum of r_regions is N. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE integer(kind=jpim),intent(in) :: N,n_collars real(kind=jprd),intent(in) :: c_polar real(kind=jprd),intent(out) :: r_regions(n_collars+2) integer(kind=jpim) :: collar_n real(kind=jprd) :: ideal_region_area,ideal_collar_area real(kind=jprd) :: a_fitting r_regions(:)=0.0_jprd r_regions(1) = 1.0_jprd if( n_collars > 0 )then ! ! Based on n_collars and c_polar, determine a_fitting, ! the collar angle such that n_collars collars fit between the polar caps. ! a_fitting = (pi-2.0_jprd*c_polar)/real(n_collars,jprd) ideal_region_area = area_of_ideal_region(N) do collar_n=1,n_collars ideal_collar_area = area_of_collar(c_polar+(collar_n-1)*a_fitting, & & c_polar+collar_n*a_fitting) r_regions(1+collar_n) = ideal_collar_area / ideal_region_area enddo endif r_regions(2+n_collars) = 1. return end subroutine ideal_region_list function ideal_collar_angle(N) result(ideal) ! ! IDEAL_COLLAR_ANGLE The ideal angle for spherical collars of an EQ partition ! ! IDEAL_COLLAR_ANGLE(N) sets ANGLE to the ideal angle for the ! spherical collars of an EQ partition of the unit sphere S^2 into N regions. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE integer(kind=jpim),intent(in) :: N real(kind=jprd) :: ideal ideal = area_of_ideal_region(N)**(0.5_jprd) return end function ideal_collar_angle subroutine round_to_naturals(N,n_collars,r_regions) ! ! ROUND_TO_NATURALS Round off a given list of numbers of regions ! ! Given N and r_regions, determine n_regions, a list of the natural number ! of regions in each collar and the polar caps. ! This list is as close as possible to r_regions, using rounding. ! The number of elements is n_collars+2. ! n_regions[1] is 1. ! n_regions[n_collars+2] is 1. ! The sum of n_regions is N. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE integer(kind=jpim),intent(in) :: N,n_collars real(kind=jprd),intent(in) :: r_regions(n_collars+2) integer(kind=jpim) :: zone_n real(kind=jprd) :: discrepancy n_regions(1:n_collars+2) = r_regions(:) discrepancy = 0.0_jprd do zone_n = 1,n_collars+2 n_regions(zone_n) = nint(r_regions(zone_n)+discrepancy); discrepancy = discrepancy+r_regions(zone_n)-real(n_regions(zone_n),jprd); enddo return end subroutine round_to_naturals function polar_colat(N) result(polar_c) ! ! Given N, determine the colatitude of the North polar spherical cap. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE integer(kind=jpim),intent(in) :: N real(kind=jprd) :: area real(kind=jprd) :: polar_c if( N == 1 ) polar_c=pi if( N == 2 ) polar_c=pi/2.0_jprd if( N > 2 )then area=area_of_ideal_region(N) polar_c=sradius_of_cap(area) endif return end function polar_colat function area_of_ideal_region(N) result(area) ! ! AREA_OF_IDEAL_REGION(N) sets AREA to be the area of one of N equal ! area regions on S^2, that is 1/N times AREA_OF_SPHERE. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE integer(kind=jpim),intent(in) :: N real(kind=jprd) :: area_of_sphere real(kind=jprd) :: area area_of_sphere = (2.0_jprd*pi**1.5_jprd/gamma(1.5_jprd)) area = area_of_sphere/real(N,jprd) return end function area_of_ideal_region function sradius_of_cap(area) result(sradius) ! ! SRADIUS_OF_CAP(AREA) returns the spherical radius of ! an S^2 spherical cap of area AREA. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE real(kind=jprd),intent(in) :: area real(kind=jprd) :: sradius sradius = 2.0_jprd*asin(sqrt(area/pi)/2.0_jprd) return end function sradius_of_cap function area_of_collar(a_top, a_bot) result(area) ! ! AREA_OF_COLLAR Area of spherical collar ! ! AREA_OF_COLLAR(A_TOP, A_BOT) sets AREA to be the area of an S^2 spherical ! collar specified by A_TOP, A_BOT, where A_TOP is top (smaller) spherical radius, ! A_BOT is bottom (larger) spherical radius. ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE real(kind=jprd),intent(in) :: a_top,a_bot real(kind=jprd) :: area area = area_of_cap(a_bot) - area_of_cap(a_top) return end function area_of_collar function area_of_cap(s_cap) result(area) ! ! AREA_OF_CAP Area of spherical cap ! ! AREA_OF_CAP(S_CAP) sets AREA to be the area of an S^2 spherical ! cap of spherical radius S_CAP. ! real(kind=jprd),intent(in) :: s_cap real(kind=jprd) :: area area = 4.0_jprd*pi * sin(s_cap/2.0_jprd)**2 return end function area_of_cap function gamma(x) result(gamma_res) ! USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE real(kind=jprd),intent(in) :: x real(kind=jprd) :: gamma_res real(kind=jprd) :: p0,p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13 real(kind=jprd) :: w,y integer(kind=jpim) :: k,n parameter (& & p0 = 0.999999999999999990e+00_jprd,& & p1 = -0.422784335098466784e+00_jprd,& & p2 = -0.233093736421782878e+00_jprd,& & p3 = 0.191091101387638410e+00_jprd,& & p4 = -0.024552490005641278e+00_jprd,& & p5 = -0.017645244547851414e+00_jprd,& & p6 = 0.008023273027855346e+00_jprd) parameter (& & p7 = -0.000804329819255744e+00_jprd,& & p8 = -0.000360837876648255e+00_jprd,& & p9 = 0.000145596568617526e+00_jprd,& & p10 = -0.000017545539395205e+00_jprd,& & p11 = -0.000002591225267689e+00_jprd,& & p12 = 0.000001337767384067e+00_jprd,& & p13 = -0.000000199542863674e+00_jprd) n = nint(x - 2) w = x - (n + 2) y = ((((((((((((p13 * w + p12) * w + p11) * w + p10) *& & w + p9) * w + p8) * w + p7) * w + p6) * w + p5) *& & w + p4) * w + p3) * w + p2) * w + p1) * w + p0 if (n > 0) then w = x - 1 do k = 2, n w = w * (x - k) end do else w = 1 do k = 0, -n - 1 y = y * (x + k) end do end if gamma_res = w / y return end function gamma END MODULE eq_regions_mod ectrans-1.8.0/src/trans/common/internal/sump_trans0_mod.F900000664000175000017500000000632115174631767024002 0ustar alastairalastair! (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. ! MODULE SUMP_TRANS0_MOD CONTAINS SUBROUTINE SUMP_TRANS0 ! Set up distributed environment for the transform package (part 0) USE EC_PARKIND ,ONLY : JPIM USE MPL_MODULE ,ONLY : MPL_GROUPS_CREATE, MPL_MYRANK, MPL_NPROC USE TPM_GEN ,ONLY : NOUT, LMPOFF, NPRINTLEV USE TPM_DISTR ,ONLY : LEQ_REGIONS, MTAGDISTGP, MTAGDISTSP, MTAGGL, & & MTAGLETR, MTAGLG, MTAGLM, MTAGML, MTAGPART, & & MYSETV, MYSETW, NPRCIDS, & & NPRGPEW, NPRGPNS, NPRTRNS, NPRTRV, NPRTRW, & & MYPROC, NPROC USE EQ_REGIONS_MOD ,ONLY : EQ_REGIONS, MY_REGION_EW, MY_REGION_NS, & & N_REGIONS, N_REGIONS_EW, N_REGIONS_NS USE PE2SET_MOD ,ONLY : PE2SET USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS IMPLICIT NONE LOGICAL :: LLP1,LLP2 INTEGER(KIND=JPIM) :: IPROC,JJ ! ------------------------------------------------------------------ LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUMP_TRANS0 ===' NPROC = NPRGPNS*NPRGPEW NPRTRNS = NPRTRW IF(MOD(NPROC,NPRTRW) /= 0 .OR. NPRTRW > NPROC) THEN CALL ABORT_TRANS('SUMP_TRANS0: NPROC INCONSISTENT WITH NPRTRW') ENDIF NPRTRV = NPROC/NPRTRW IF(LLP1) WRITE(NOUT,*)'NPROC =',NPROC,' NPRGPNS=',NPRGPNS,' NPRGPEW=',& & NPRGPEW,' NPRTRW=',NPRTRW,' NPRTRV=',NPRTRV IF(NPROC > 1 ) THEN IPROC = MPL_NPROC() IF(IPROC /= NPROC) THEN WRITE(NOUT,*) 'SUMP_TRANS0: NPROC=',NPROC,' BUT MPL_NPROC RETURNS',& & IPROC CALL ABORT_TRANS('SUMP_TRANS0: NPROC INCONSISTENT WITH MPL_NPROC') ENDIF MYPROC = MPL_MYRANK() ELSE MYPROC = 1 ENDIF IF (MYPROC > NPROC) THEN CALL ABORT_TRANS('SUMP_TRANS0: INCONSISTENCY IN NUMBER OF PROCESSORS USED') ENDIF IF( LEQ_REGIONS )THEN ALLOCATE(N_REGIONS(NPROC+2)) N_REGIONS(:)=0 CALL EQ_REGIONS(NPROC) ELSE N_REGIONS_NS=NPRGPNS ALLOCATE(N_REGIONS(N_REGIONS_NS)) N_REGIONS(:)=NPRGPEW N_REGIONS_EW=NPRGPEW ENDIF CALL PE2SET(MYPROC,MY_REGION_NS,MY_REGION_EW,MYSETW,MYSETV) IF(LLP1) WRITE(NOUT,*)'MYPROC=',MYPROC,'MY_REGION_NS =',MY_REGION_NS,& & ' MY_REGION_EW=',MY_REGION_EW,' MYSETW=',MYSETW,' MYSETV=',MYSETV ALLOCATE(NPRCIDS(NPROC)) IF(LLP2)WRITE(NOUT,9) 'NPRCIDS ',SIZE(NPRCIDS ),SHAPE(NPRCIDS ) DO JJ=1,NPROC NPRCIDS(JJ) = JJ ENDDO ! Message passing tags MTAGLETR = 18000 MTAGML = 19000 MTAGLG = 20000 MTAGPART = 21000 MTAGDISTSP = 22000 MTAGGL = 23000 MTAGLM = 24000 MTAGDISTGP = 25000 ! Create communicators for MPI groups IF (.NOT.LMPOFF) THEN CALL MPL_GROUPS_CREATE(NPRTRW, NPRTRV) ENDIF ! Setup labels for timing package (gstats) ! CF ifs/utility GSTATS_OUTPUT_IFS ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUMP_TRANS0 END MODULE SUMP_TRANS0_MOD ectrans-1.8.0/src/trans/common/internal/wts500_mod.F900000664000175000017500000056015715174631767022605 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE WTS500_MOD CONTAINS SUBROUTINE WTS500(PX,PW,KN) USE EC_PARKIND ,ONLY : JPIM, JPRD IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KN REAL(KIND=JPRD), INTENT(OUT) :: PX(:),PW(:) ! This routine returns a set of Gaussian nodes and weights for ! integrating the functions exp(lambda*x)dx over the range x=0 to x=infinity. ! They work for lambda in the range [1,501]. The accuracy ! of the quadrature for each n is given in the tables below. ! Input arguments: ! n - number of weights and nodes in the quadrature. This must ! be an integer in the range [2,56]. ! ! Output arguments: ! w - weights ! x - nodes ! ! ! The following table gives the approximate accuracy of the weights in ! this file, that is to say the experimentally determined maximum ! absolute error for lambda in the range [1,501]. ! ! 2 0.76126E-01 ! 3 0.26903E-01 ! 4 0.88758E-02 ! 5 0.28110E-02 ! 6 0.86785E-03 ! 7 0.26276E-03 ! 8 0.78346E-04 ! 9 0.23066E-04 ! 10 0.67184E-05 ! 11 0.19386E-05 ! 12 0.55482E-06 ! 13 0.15762E-06 ! 14 0.44478E-07 ! 15 0.12474E-07 ! 16 0.34787E-08 ! 17 0.96498E-09 ! 18 0.26636E-09 ! 19 0.73174E-10 ! 20 0.20013E-10 ! 21 0.54503E-11 ! 22 0.14783E-11 ! 23 0.39937E-12 ! 24 0.10749E-12 ! 25 0.28822E-13 ! 26 0.77011E-14 ! 27 0.20993E-14 ! 28 0.59593E-15 ! (The accuracies beyond this point are ! only available if this routine is converted ! to extended precision.) ! ! 29 0.16665E-15 ! 30 0.45938E-16 ! 31 0.12483E-16 ! 32 0.33436E-17 ! 33 0.88209E-18 ! 34 0.22896E-18 ! 35 0.58363E-19 ! 36 0.15182E-19 ! 37 0.45892E-20 ! 38 0.13452E-20 ! 39 0.38384E-21 ! 40 0.10683E-21 ! 41 0.29025E-22 ! 42 0.76955E-23 ! 43 0.19878E-23 ! 44 0.49867E-24 ! 45 0.12879E-24 ! 46 0.38890E-25 ! 47 0.11493E-25 ! 48 0.32717E-26 ! 49 0.89977E-27 ! 50 0.23916E-27 ! 51 0.66534E-28 ! 52 0.20256E-28 ! 53 0.60754E-29 ! 54 0.17974E-29 ! 55 0.52173E-30 ! 56 0.14656E-30 ! 57 0.39867E-31 ! 58 0.17622E-31 ! 59 0.11941E-31 if(kn < 1 .or. kn > 59) CALL ABOR1('kn out of bounds in wts500') if(kn == 1) then px( 1)= 0.30029234138173323099658823269124393D+00 pw( 1)= 0.10474544159373900054024730385996879D+01 endif if(kn == 2) then px( 1)= 0.44614645646035084305052271657195780D-01 px( 2)= 0.69921614559509068409005059560416520D+00 pw( 1)= 0.15994862626671497398269903651565162D+00 pw( 2)= 0.15511944041990193294522419186360192D+01 endif if(kn == 3) then px( 1)= 0.11857389353662594950547350532174902D-01 px( 2)= 0.16764835416208964726306668598724940D+00 px( 3)= 0.11277491807394385305149473243132366D+01 pw( 1)= 0.40534466810113107834140226328650886D-01 pw( 2)= 0.36261372044374320167772351965467234D+00 pw( 3)= 0.19347454032003660753035080254268649D+01 endif if(kn == 4) then px( 1)= 0.57654208655188821571537226422468374D-02 px( 2)= 0.62523167781181198280172417136126064D-01 px( 3)= 0.36533207087496350173593536437526512D+00 px( 4)= 0.16157524591822212021884702173778156D+01 pw( 1)= 0.17868545000488806425866630797084082D-01 pw( 2)= 0.12328668633600752343455555544669733D+00 pw( 3)= 0.58372673164630844216911861958288950D+00 pw( 4)= 0.22766170591050845697618451516268360D+01 endif if(kn == 5) then px( 1)= 0.38286655100887720869535305553503767D-02 px( 2)= 0.32638654131646742439488396483219523D-01 px( 3)= 0.15979343932440245421190120326583297D+00 px( 4)= 0.62593598592475461862138219614406608D+00 px( 5)= 0.21448850159686373839369069493121931D+01 pw( 1)= 0.11006282598632254556602552524231582D-01 pw( 2)= 0.57230982733825644334586234468135637D-01 pw( 3)= 0.23302193704059872350599634911774233D+00 pw( 4)= 0.80399187922220639155300759119683454D+00 pw( 5)= 0.25817835060095957471682462945418890D+01 endif if(kn == 6) then px( 1)= 0.29149725976167556773168063131622477D-02 px( 2)= 0.21103262424016434877304140537976324D-01 px( 3)= 0.87672665103786085283260733993906787D-01 px( 4)= 0.30362191434277672991331660483079722D+00 px( 5)= 0.93772122523975475283401768866415608D+00 px( 6)= 0.27034204049910086432949276908848690D+01 pw( 1)= 0.80264082196721958922253358145693741D-02 pw( 2)= 0.33206285080799577093824435206894388D-01 pw( 3)= 0.11527314673621704717905199327206330D+00 pw( 4)= 0.35781407343251622864391524621893261D+00 pw( 5)= 0.10155006971456147012687855907386742D+01 pw( 6)= 0.28564602273790248848620772701419901D+01 endif if(kn == 7) then px( 1)= 0.23756434216797693908355583003051663D-02 px( 2)= 0.15535118461800569190547935165674497D-01 px( 3)= 0.56551273947723240042834250291153011D-01 px( 4)= 0.17450996559452745580564075650691432D+00 px( 5)= 0.49112500667928528178358415821262749D+00 px( 6)= 0.12919504684055881399873474932878924D+01 px( 7)= 0.32851412356973227675206901468229149D+01 pw( 1)= 0.63886696350675163666711135442919764D-02 pw( 2)= 0.22442242541224196499797804610442189D-01 pw( 3)= 0.67162457789171790971598253749543852D-01 pw( 4)= 0.18766490984256656291382113580254403D+00 pw( 5)= 0.48993342911988760795594155472540210D+00 pw( 6)= 0.12160105557427987424854903052204337D+01 pw( 7)= 0.31065668529411483170389922159304207D+01 endif if(kn == 8) then px( 1)= 0.20132180607225834852983700686031058D-02 px( 2)= 0.12364145427770238507453563351438370D-01 px( 3)= 0.40779487004322342225816753965428875D-01 px( 4)= 0.11391148589791378330792648499651137D+00 px( 5)= 0.29412883145944878287611616309747638D+00 px( 6)= 0.71837098644914450185415022533227351D+00 px( 7)= 0.16816853747148161279323645594606599D+01 px( 8)= 0.38855951611162649511701947653116899D+01 pw( 1)= 0.53408830450397378295721475271713427D-02 pw( 2)= 0.16787984180357441921393643943808306D-01 pw( 3)= 0.44204970292771876400860637563463140D-01 pw( 4)= 0.11185011190895920238718302559774708D+00 pw( 5)= 0.27016191944753418682586773667091217D+00 pw( 6)= 0.62450892495416087531923817566640810D+00 pw( 7)= 0.14051940584215133597891405916743820D+01 pw( 8)= 0.33364764999199772405176908767598180D+01 endif if(kn == 9) then px( 1)= 0.17503557878075214519879036524833375D-02 px( 2)= 0.10330054871723184754037951908660005D-01 px( 3)= 0.31732206325445549848937295392421049D-01 px( 4)= 0.81679121803401719155156637120993002D-01 px( 5)= 0.19535573613157974971806765507983509D+00 px( 6)= 0.44595223788074039354969352640100852D+00 px( 7)= 0.98135220945386835905397405725519927D+00 px( 8)= 0.21015170770020791654126380210416672D+01 px( 9)= 0.45016099625796459085057556421321067D+01 pw( 1)= 0.46046107862322611600702922635137510D-02 pw( 2)= 0.13429769279555420282230890098322098D-01 pw( 3)= 0.31849272894061216190385847667286999D-01 pw( 4)= 0.73619249380405585299506449662883408D-01 pw( 5)= 0.16535947795274881422091783969932427D+00 pw( 6)= 0.35934417872243713158616629815331565D+00 pw( 7)= 0.75859660458155596407004967675485659D+00 pw( 8)= 0.15835611580085742332645675327785911D+01 pw( 9)= 0.35495334121390922353050388191171761D+01 endif if(kn == 10) then px( 1)= 0.15499542669794147311761132610985078D-02 px( 2)= 0.89096688398509678030924958952986541D-02 px( 3)= 0.26016129693043413683698040760210971D-01 px( 4)= 0.62749208598031754292711006026615926D-01 px( 5)= 0.14050353407849426047312501552279980D+00 px( 6)= 0.30181414123622395598472969521213967D+00 px( 7)= 0.62857185766887058395879604119303521D+00 px( 8)= 0.12763299399934852402803633611287669D+01 px( 9)= 0.25471652578226896546390447678170800D+01 px(10)= 0.51308067782658204682801321291953140D+01 pw( 1)= 0.40548253986991389304086648382669812D-02 pw( 2)= 0.11236188731318700188319947717229244D-01 pw( 3)= 0.24538592970816425402207400802497825D-01 pw( 4)= 0.52343517158460444258926972420783323D-01 pw( 5)= 0.10996558531241373841512937168184451D+00 pw( 6)= 0.22576984249893556435278829920283551D+00 pw( 7)= 0.45261772769497660240184928082408646D+00 pw( 8)= 0.89046194530658792052229355508350808D+00 pw( 9)= 0.17519181692872931385803490555209237D+01 pw(10)= 0.37483184442175079452559119390314762D+01 endif if(kn == 11) then px( 1)= 0.13916503869954620980214122938112018D-02 px( 2)= 0.78558050039620362116422912802704097D-02 px( 3)= 0.22120351963459063625179184464273817D-01 px( 4)= 0.50713242013627782652925282235350304D-01 px( 5)= 0.10742319887758113859279057980251631D+00 px( 6)= 0.21869117548117680828718663672766937D+00 px( 7)= 0.43336030838054496927092430378951163D+00 px( 8)= 0.84018288532692476091948497009100848D+00 px( 9)= 0.15999462842086233335871841089805130D+01 px(10)= 0.30151891304900922172275251687511795D+01 px(11)= 0.57713337136325357659044166408988553D+01 pw( 1)= 0.36266510989460802397873164288690734D-02 pw( 2)= 0.96950369134995745371692684658412310D-02 pw( 3)= 0.19868559916434820960232503677049332D-01 pw( 4)= 0.39531505533000821496522977944503206D-01 pw( 5)= 0.78139977968766268496958310477317134D-01 pw( 6)= 0.15225813478813020210433348166511355D+00 pw( 7)= 0.29137456345793780649576074277273596D+00 pw( 8)= 0.54807495314077461646456170049418256D+00 pw( 9)= 0.10191215020827390969142637205874466D+01 pw(10)= 0.19111370110068844260874568369820828D+01 pw(11)= 0.39348541670555911675625708842098543D+01 endif if(kn == 12) then px( 1)= 0.12632156319939695579215561432558385D-02 px( 2)= 0.70387146180879286642550585568639377D-02 px( 3)= 0.19302659916972801592515201957656444D-01 px( 4)= 0.42551194105513329489354627472007290D-01 px( 5)= 0.86085992365439625679560348707191417D-01 px( 6)= 0.16725813918676372888922850902058409D+00 px( 7)= 0.31700589361943171070304767229555238D+00 px( 8)= 0.58951191619791589683106843254408061D+00 px( 9)= 0.10788413480839543106858840025589018D+01 px(10)= 0.19492439011651360999619060490611511D+01 px(11)= 0.35027911449093405858739078699931569D+01 px(12)= 0.64217203451802643126959421992550844D+01 pw( 1)= 0.32827550127604954815335522044868924D-02 pw( 2)= 0.85507540197432347733759971108613029D-02 pw( 3)= 0.16691067543209908975186757261638663D-01 pw( 4)= 0.31305443669027793014029811945580099D-01 pw( 5)= 0.58567896813505682343320309424861089D-01 pw( 6)= 0.10877780693120356209434163632243069D+00 pw( 7)= 0.19948368504455875259042629374456601D+00 pw( 8)= 0.36073967408442558747147434040847228D+00 pw( 9)= 0.64434179114194185133722660716595021D+00 pw(10)= 0.11440591869200469793282529105709381D+01 pw(11)= 0.20620613323447639907885178297356148D+01 pw(12)= 0.41107547758236817466309181956604953D+01 endif if(kn == 13) then px( 1)= 0.11568070520917003084172899381406952D-02 px( 2)= 0.63841031288591798815234066736007959D-02 px( 3)= 0.17167711063873432612672836118321923D-01 px( 4)= 0.36716019315047555758945584779212588D-01 px( 5)= 0.71538434902470635056036514447143755D-01 px( 6)= 0.13352689214829569833793677431883262D+00 px( 7)= 0.24327491638178311179091055382048232D+00 px( 8)= 0.43570388054574854249210127119178039D+00 px( 9)= 0.76944422789933215499607649746035088D+00 px(10)= 0.13426076062689412695687622546331410D+01 px(11)= 0.23216397056754496795639041380757885D+01 px(12)= 0.40076692644610800412009568941378368D+01 px(13)= 0.70807767026725092855482684561044825D+01 pw( 1)= 0.29999461201538405335426373656007144D-02 pw( 2)= 0.76647148893919466896210631066410433D-02 pw( 3)= 0.14413099397767107036014918126327008D-01 pw( 4)= 0.25735254465096214146045248201904623D-01 pw( 5)= 0.45838911095175772187879197848974379D-01 pw( 6)= 0.81479609103017647524386799211775902D-01 pw( 7)= 0.14368582127715272775954689518716653D+00 pw( 8)= 0.25069362938769053221329919008840415D+00 pw( 9)= 0.43269827884396605348016529885550754D+00 pw(10)= 0.74044407474304235266031833325121847D+00 pw(11)= 0.12650477516195139055095418091901788D+01 pw(12)= 0.22054684388256755415929800672572855D+01 pw(13)= 0.42773285665753897495906588616832298D+01 endif if(kn == 14) then px( 1)= 0.10671394835726993643401190254501129D-02 px( 2)= 0.58463219387999205854721615603871185D-02 px( 3)= 0.15490001691602291418567227600617406D-01 px( 4)= 0.32358969391919711170669944447127038D-01 px( 5)= 0.61149820125492142314645657324953302D-01 px( 6)= 0.11030358671474348741774495105493271D+00 px( 7)= 0.19410127886489828338777312891458955D+00 px( 8)= 0.33608975279087339935499749076365196D+00 px( 9)= 0.57467416136431217184690034730315880D+00 px(10)= 0.97213677138209888520957230352753264D+00 px(11)= 0.16296229550658990298708599801796051D+01 px(12)= 0.27148835813646440924906285656041458D+01 px(13)= 0.45279078084008377593720415669623160D+01 px(14)= 0.77475240501693856896302484250295344D+01 pw( 1)= 0.27629693325443496023249306681806622D-02 pw( 2)= 0.69561289060164080762372517703735452D-02 pw( 3)= 0.12707947219219552524391040926686251D-01 pw( 4)= 0.21789865957161394780641970526254899D-01 pw( 5)= 0.37165450147146819315861454426090832D-01 pw( 6)= 0.63467023298815675308212729382023282D-01 pw( 7)= 0.10796235746711791223910582849233129D+00 pw( 8)= 0.18227038265561301471910246064953376D+00 pw( 9)= 0.30504176678107803021400309104091856D+00 pw(10)= 0.50632019264974725562617387788020652D+00 pw(11)= 0.83570187185256971962451509332190849D+00 pw(12)= 0.13820370228408991881296397708221031D+01 pw(13)= 0.23420578929692185520173441027903024D+01 pw(14)= 0.44356505634271121964311698817472400D+01 endif if(kn == 15) then px( 1)= 0.99051088742239546911827900108699496D-03 px( 2)= 0.53956859621998690434579925957171424D-02 px( 3)= 0.14133099949775560668841655685250135D-01 px( 4)= 0.28986898223070841544449976160392634D-01 px( 5)= 0.53435705913102094881195404152789995D-01 px( 6)= 0.93645206162765297669714244403422362D-01 px( 7)= 0.15985934779166946137952895657247365D+00 px( 8)= 0.26857062154409215737173322640809941D+00 px( 9)= 0.44599642616020670957476031778753703D+00 px(10)= 0.73354905454082877060570463263769745D+00 px(11)= 0.11964718339441153959477756602491571D+01 px(12)= 0.19381471569679916567453627291281352D+01 px(13)= 0.31270149297417650854875367303912466D+01 px(14)= 0.50618963332858424622137075227057629D+01 px(15)= 0.84211464685237105475663901928632362D+01 pw( 1)= 0.25613355491269301472247025631698555D-02 pw( 2)= 0.63749573647622919143443050089843640D-02 pw( 3)= 0.11385424145275303734569902166128714D-01 pw( 4)= 0.18885541036270664981042580089520502D-01 pw( 5)= 0.31017529676997219516938356388920347D-01 pw( 6)= 0.51073868255802230619626900228351940D-01 pw( 7)= 0.84046732560351404937544837831163072D-01 pw( 8)= 0.13765675735555740692176543168654955D+00 pw( 9)= 0.22395807420699105358370420342497012D+00 pw(10)= 0.36179555862328041144887460703035761D+00 pw(11)= 0.58087464283264030346041192108355511D+00 pw(12)= 0.92964960101952292137644303560667260D+00 pw(13)= 0.14950837580230651438254975578030658D+01 pw(14)= 0.24724522131384988410164432454754806D+01 pw(15)= 0.45866150536692880851084073088444439D+01 endif if(kn == 16) then px( 1)= 0.92424556053971804395203579030996377D-03 px( 2)= 0.50119857035276309167085959684639920D-02 px( 3)= 0.13010148344461010136325444162584406D-01 px( 4)= 0.26298847872231801244580127340702382D-01 px( 5)= 0.47514597563807100058998705367026609D-01 px( 6)= 0.81270265524596050675960333331275375D-01 px( 7)= 0.13512212854897371400148043770796492D+00 px( 8)= 0.22099831669763609789452208029307415D+00 px( 9)= 0.35743533198723356545740999174337465D+00 px(10)= 0.57303934564748771037392604303226621D+00 px(11)= 0.91178803183594107838418321994075593D+00 px(12)= 0.14412990877209031034459072051939979D+01 px(13)= 0.22665732295803028877227882175486339D+01 px(14)= 0.35563219327028564804732957321586739D+01 px(15)= 0.56082683107347449605789692452752341D+01 px(16)= 0.91009557053769985645449386780285663D+01 pw( 1)= 0.23875730074587121522484947794868875D-02 pw( 2)= 0.58885836354644078094393546205524519D-02 pw( 3)= 0.10329316404953667658388475423521547D-01 pw( 4)= 0.16675469828365142363971545189694061D-01 pw( 5)= 0.26509288186703737427234519675535818D-01 pw( 6)= 0.42238486164148838677474311842225533D-01 pw( 7)= 0.67416914217096425505948847545251978D-01 pw( 8)= 0.10736855475828194921843388490206803D+00 pw( 9)= 0.17018723045468088538746817095795499D+00 pw(10)= 0.26821766647062034548841613907117539D+00 pw(11)= 0.42033354906191972945041277677914052D+00 pw(12)= 0.65579398374758854246146234684717478D+00 pw(13)= 0.10219768938841077866955934226960186D+01 pw(14)= 0.16043073953579345130225854215735434D+01 pw(15)= 0.25972025694404090887006269510370113D+01 pw(16)= 0.47309741605753804978373532621330190D+01 endif if(kn == 17) then px( 1)= 0.86635871969021922697368620380719171D-03 px( 2)= 0.46809392638055264395521402125297454D-02 px( 3)= 0.12063365169996780691336553708488918D-01 px( 4)= 0.24103101327380368111361062755741909D-01 px( 5)= 0.42839783531484774994275135488102184D-01 px( 6)= 0.71796215026314425758110076991702409D-01 px( 7)= 0.11667729790867741765510249018437646D+00 px( 8)= 0.18634666322578944021297170782701070D+00 px( 9)= 0.29431002802504656436686613469103506D+00 px(10)= 0.46097947485749393786168585286436753D+00 px(11)= 0.71707474488613285211211458276745483D+00 px(12)= 0.11087399814864640384073502346191564D+01 px(13)= 0.17054769509601451753469079240400202D+01 px(14)= 0.26134294141755383267430920003219774D+01 px(15)= 0.40013054555328633047267069424482020D+01 px(16)= 0.61658542528138849120122933226961818D+01 px(17)= 0.97863651496368699835621922821544266D+01 pw( 1)= 0.22362031087732985183223720565899613D-02 pw( 2)= 0.54748197495181657019575138084577960D-02 pw( 3)= 0.94654762542541339323585186529928706D-02 pw( 4)= 0.14944978294023789536885689508849665D-01 pw( 5)= 0.23104141337215046610391678093559219D-01 pw( 6)= 0.35743858431643263735692324511510319D-01 pw( 7)= 0.55471485911701630593769305151799996D-01 pw( 8)= 0.86081253422553517325473099895533971D-01 pw( 9)= 0.13319208512009976788628468120231006D+00 pw(10)= 0.20518383340535621745997474262468218D+00 pw(11)= 0.31457026902282458163459435604989060D+00 pw(12)= 0.48013605826872593355323421318271994D+00 pw(13)= 0.73064164224806746286555643417201840D+00 pw(14)= 0.11124853152432080885402590631214998D+01 pw(15)= 0.17098620915289443753971369096340138D+01 pw(16)= 0.27167962114974631513284929060677873D+01 pw(17)= 0.48693666605809874327613580765223186D+01 endif if(kn == 18) then px( 1)= 0.81534546944719247652148851160350705D-03 px( 2)= 0.43921383032957290852797835084086745D-02 px( 3)= 0.11252831287113979876218879126262041D-01 px( 4)= 0.22272809918423842477230910840641111D-01 px( 5)= 0.39059190621733757694717358109890744D-01 px( 6)= 0.64351345855435130240707418934923649D-01 px( 7)= 0.10254178168021558618169365620644254D+00 px( 8)= 0.16036912239056014178785088963204099D+00 px( 9)= 0.24793085437822483127871211432445117D+00 px(10)= 0.38020606680363380296594904808373420D+00 px(11)= 0.57931198537370336370768123946111904D+00 px(12)= 0.87782030094596229067122251201903469D+00 px(13)= 0.13236886505899049407415999004449793D+01 px(14)= 0.19878981731926587403713993880950166D+01 px(15)= 0.29773742063276571130424960439239811D+01 px(16)= 0.44606479473592453417809733684642453D+01 px(17)= 0.67336454736569532214104241445939923D+01 px(18)= 0.10476870213785278025831291196419849D+02 pw( 1)= 0.21031106134613254745224559686561387D-02 pw( 2)= 0.51180225478690087298803997939678307D-02 pw( 3)= 0.87447370935970058836913883371899363D-02 pw( 4)= 0.13556333730223126136121123231259769D-01 pw( 5)= 0.20464410216338036789779126385561199D-01 pw( 6)= 0.30840826466947410241261173555971053D-01 pw( 7)= 0.46646725563835069845910497771424517D-01 pw( 8)= 0.70665992632893967524146851106623791D-01 pw( 9)= 0.10691711075454395961181073477729829D+00 pw(10)= 0.16126547210903485792084905962898804D+00 pw(11)= 0.24229509616610255685205188073761953D+00 pw(12)= 0.36259234617456851620630123413473169D+00 pw(13)= 0.54077318770758097024862643911836327D+00 pw(14)= 0.80508517291294611337977692389747849D+00 pw(15)= 0.12010568605667241321654935386099247D+01 pw(16)= 0.18119190754724382445935517697030275D+01 pw(17)= 0.28316640971192016310500153967949394D+01 pw(18)= 0.50023398513295527439214736503709354D+01 endif if(kn == 19) then px( 1)= 0.77004314038027538186473565824644713D-03 px( 2)= 0.41377999330050882914315571254404182D-02 px( 3)= 0.10550059721986121680218103475882631D-01 px( 4)= 0.20721165151890931602860316370210977D-01 px( 5)= 0.35938464219963308088025295472146865D-01 px( 6)= 0.58366846240533488939212086566679739D-01 px( 7)= 0.91445878837421954880767431790624735D-01 px( 8)= 0.14039874091074934933241224785817280D+00 px( 9)= 0.21294392165350590964714225395783962D+00 px(10)= 0.32034449388214261059174416345147381D+00 px(11)= 0.47894630556295055579310759106626288D+00 px(12)= 0.71240272881825772752142518345001522D+00 px(13)= 0.10548945187200170944433178271823931D+01 px(14)= 0.15558853016268620673915640887496031D+01 px(15)= 0.22875048294126069831169385958820912D+01 px(16)= 0.33571879025245227476638520498261293D+01 px(17)= 0.49331870217088227943005162552018204D+01 px(18)= 0.73107657529555946558412435928344152D+01 px(19)= 0.11172033293322081236666941378477642D+02 pw( 1)= 0.19851404434292128161572603749012797D-02 pw( 2)= 0.48068259850224485883558544189622861D-02 pw( 3)= 0.81333622551403917938013382271885652D-02 pw( 4)= 0.12418290368147926797125266347472059D-01 pw( 5)= 0.18370520996399132266929646675963512D-01 pw( 6)= 0.27051260748772011764068846294046263D-01 pw( 7)= 0.39965808856363914121506612420685851D-01 pw( 8)= 0.59209186306872358867005896800202963D-01 pw( 9)= 0.87733163743117132114765866319084195D-01 pw(10)= 0.12975590467993236932824761605587432D+00 pw(11)= 0.19133746801777096221136436300603368D+00 pw(12)= 0.28119521004597734924657796391935552D+00 pw(13)= 0.41191451657988898367993353735036478D+00 pw(14)= 0.60189235614006428503841831846326255D+00 pw(15)= 0.87887424161089233540150542700936886D+00 pw(16)= 0.12876310724220064351766502884115249D+01 pw(17)= 0.19106555786053829247748848866287425D+01 pw(18)= 0.29421880423760456779000496029582960D+01 pw(19)= 0.51303663807899157605725316747503964D+01 endif if(kn == 20) then px( 1)= 0.72953870581824875898426590899779881D-03 px( 2)= 0.39119765013576279090594732249736674D-02 px( 3)= 0.99341482544177994609830844666447236D-02 px( 4)= 0.19386948343749964006247704258211447D-01 px( 5)= 0.33316937960159820123580449168857215D-01 px( 6)= 0.53460240758464289437871006955420897D-01 px( 7)= 0.82550373662718413944945968267436420D-01 px( 8)= 0.12470333365766989270462564119778831D+00 px( 9)= 0.18593248929460522396945432673813683D+00 px(10)= 0.27488824477709750979845021236505632D+00 px(11)= 0.40393075219294011341163041535306531D+00 px(12)= 0.59066371193107531104946391158049526D+00 px(13)= 0.86011311520208939992657730367961144D+00 px(14)= 0.12478475018108315971898483004517581D+01 px(15)= 0.18045718085352853467882826664457563D+01 px(16)= 0.26032962838705539076929338309800964D+01 px(17)= 0.37517626775845063477806691210141684D+01 px(18)= 0.54178931704948062041809621881307184D+01 px(19)= 0.78964489442873309920085649476831128D+01 px(20)= 0.11871472067202549660846380067126100D+02 pw( 1)= 0.18798307004678227911126701301382902D-02 pw( 2)= 0.45327579066213798867372241143837770D-02 pw( 3)= 0.76074915984009747299662992379957293D-02 pw( 4)= 0.11468617772837279819666929117999041D-01 pw( 5)= 0.16675567273387276975224875991907841D-01 pw( 6)= 0.24060338209931569028899923305997740D-01 pw( 7)= 0.34797589593340192429611675508702300D-01 pw( 8)= 0.50498483539096564292114787807163509D-01 pw( 9)= 0.73383972617080340693094946803759227D-01 pw(10)= 0.10656241858153477344295213679085888D+00 pw(11)= 0.15442089967699606004539206241769081D+00 pw(12)= 0.22316517325789412150938929616587900D+00 pw(13)= 0.32158746804288047814456613183637546D+00 pw(14)= 0.46221802166864090447194287669501892D+00 pw(15)= 0.66320650916245908698703462902787156D+00 pw(16)= 0.95182294118921990028099509733606027D+00 pw(17)= 0.13721884223731472188837264029436159D+01 pw(18)= 0.20062479833990429444286070644467212D+01 pw(19)= 0.30487071357319501782576369389563967D+01 pw(20)= 0.52538573669990067214113994100342659D+01 endif if(kn == 21) then px( 1)= 0.69310486169589490054767779485652272D-03 px( 2)= 0.37100374076510691098395748526914731D-02 px( 3)= 0.93893881986074420164580675137225674D-02 px( 4)= 0.18225818290917406339248365551994452D-01 px( 5)= 0.31081498488793808069000194256763116D-01 px( 6)= 0.49367420729419602783748969736699563D-01 px( 7)= 0.75284896750519291461000850881359128D-01 px( 8)= 0.11212409497044480168252045403791321D+00 px( 9)= 0.16464732212808249809258249926002432D+00 px(10)= 0.23962225781352520103022311097593359D+00 px(11)= 0.34658518012264822513642471749928831D+00 px(12)= 0.49892252217405192191396093341852149D+00 px(13)= 0.71538674271382417280638826801508549D+00 px(14)= 0.10222215706608203725632212510312547D+01 px(15)= 0.14561846864798943048112298539958500D+01 px(16)= 0.20689966860645877444413948503855558D+01 px(17)= 0.29343325491322992822962883455667422D+01 px(18)= 0.41600923418527605289681744860608923D+01 px(19)= 0.59138510177367345119623187111536027D+01 px(20)= 0.84900211059998571872908583995965399D+01 px(21)= 0.12574850278864023350809778583936857D+02 pw( 1)= 0.17852307235103793959959450796716884D-02 pw( 2)= 0.42893635684453385047417019848134615D-02 pw( 3)= 0.71497939239830042802199211798008382D-02 pw( 4)= 0.10663735418026519276123538929713931D-01 pw( 5)= 0.15278738558420813530874306732239620D-01 pw( 6)= 0.21655078725685226823011775486802689D-01 pw( 7)= 0.30722016510142553890174563226245394D-01 pw( 8)= 0.43741403514742541630405757195910036D-01 pw( 9)= 0.62420477800170703110133642765679935D-01 pw(10)= 0.89101011801730193914410815797468243D-01 pw(11)= 0.12703103910528559102170033988553577D+00 pw(12)= 0.18073427743399167030424190804804963D+00 pw(13)= 0.25651888703698665673377349665161239D+00 pw(14)= 0.36320523524230891449268691236436560D+00 pw(15)= 0.51323006313409951821184870857512202D+00 pw(16)= 0.72448352105440485035350350605592673D+00 pw(17)= 0.10237957354057707173113819962280747D+01 pw(18)= 0.14547382360170350806458262214201030D+01 pw(19)= 0.20988676887781728328899280598296916D+01 pw(20)= 0.31515233601433750723678379202457850D+01 pw(21)= 0.53731727475008532237843822389416189D+01 endif if(kn == 22) then px( 1)= 0.66015487793114579672026064530843580D-03 px( 2)= 0.35283188763257655749934705032913356D-02 px( 3)= 0.89037268484852140335335192775132156D-02 px( 4)= 0.17204887313904086178312640698870646D-01 px( 5)= 0.29150571838447577747778236163957035D-01 px( 6)= 0.45901615793714000736387715594203021D-01 px( 7)= 0.69252127065257752538232461849428663D-01 px( 8)= 0.10186530460793644200891559033979032D+00 px( 9)= 0.14756646191534939234956638050262194D+00 px(10)= 0.21173627302990231446602872154763540D+00 px(11)= 0.30186392834135377102923595739844832D+00 px(12)= 0.42832456502483048109845734510065518D+00 px(13)= 0.60545815580026546162531862085612489D+00 px(14)= 0.85305900599439063193443527117705937D+00 px(15)= 0.11984444149249300732981072917233551D+01 px(16)= 0.16793849380767164321266153811733636D+01 px(17)= 0.23484259421990250059871794075320909D+01 px(18)= 0.32797346839031417791643463913803933D+01 px(19)= 0.45812624093642886254220734381797637D+01 px(20)= 0.64202435545325521457505355440378480D+01 px(21)= 0.90908861089411744472574137099194608D+01 px(22)= 0.13281870386631548366752315803495071D+02 pw( 1)= 0.16997739815079876291270142303147830D-02 pw( 2)= 0.40716314869569174969368080298995427D-02 pw( 3)= 0.67473810622389953786984914722964259D-02 pw( 4)= 0.99723772588960829502246883384624672D-02 pw( 5)= 0.14109253034463888804804922921072868D-01 pw( 6)= 0.19687945390172770224722572299963933D-01 pw( 7)= 0.27452171417575159428955066586690985D-01 pw( 8)= 0.38405330139190366155267988240486796D-01 pw( 9)= 0.53884692766803369761362767720533598D-01 pw(10)= 0.75690346610129349832179626694927492D-01 pw(11)= 0.10627642236395592176596973365055862D+00 pw(12)= 0.14901040431853077087285757833822327D+00 pw(13)= 0.20852197820697925399881980495903384D+00 pw(14)= 0.29118491216948479495401093995994782D+00 pw(15)= 0.40581134430662519733362245846705041D+00 pw(16)= 0.56471875154845478179304492458155087D+00 pw(17)= 0.78553695828755046999062010778990119D+00 pw(18)= 0.10946963582465286266450172551190923D+01 pw(19)= 0.15353099122697920414083249854348604D+01 pw(20)= 0.21886787280255501097880613119022761D+01 pw(21)= 0.32509064591655802312953073550183727D+01 pw(22)= 0.54886295320492726768301302193581765D+01 endif if(kn == 23) then px( 1)= 0.63021006363433841831474149369938629D-03 px( 2)= 0.33638809698722088589479529444503357D-02 px( 3)= 0.84677484260852652320615476282127309D-02 px( 4)= 0.16299243886097943905725295278638059D-01 px( 5)= 0.27464030423556247673984741054128575D-01 px( 6)= 0.42927866788160825736932098072471507D-01 px( 7)= 0.64169139230662564082303838471065529D-01 px( 8)= 0.93367767657860048911427490092659179D-01 px( 9)= 0.13363456957733254533882679272072078D+00 px(10)= 0.18930799757692553449088970134122038D+00 px(11)= 0.26636229253087365091814709204751323D+00 px(12)= 0.37297580801326442775998852633706569D+00 px(13)= 0.52031366792206514283148817023645741D+00 px(14)= 0.72359600291057382682653618452186879D+00 px(15)= 0.10035561979187412137041345167147008D+01 px(16)= 0.13884527722049286720427614547615987D+01 px(17)= 0.19169141925914051220031027488430615D+01 px(18)= 0.26421501677657864516298531009004741D+01 px(19)= 0.36386833380196488331409942198293287D+01 px(20)= 0.50144408008467284169777642211293427D+01 px(21)= 0.69363388633219643316723260573935269D+01 px(22)= 0.96985139442985089392873665294609340D+01 px(23)= 0.13992267642385099650757505185917464D+02 pw( 1)= 0.16221873306891233611184498841470861D-02 pw( 2)= 0.38756062368028647892929037543456805D-02 pw( 3)= 0.63904681228155448198104664799116312D-02 pw( 4)= 0.93716130533642383510190970859726025D-02 pw( 5)= 0.13116359133127231514779092120465823D-01 pw( 6)= 0.18054564644654175010476006376716577D-01 pw( 7)= 0.24787545528949442975874855915817576D-01 pw( 8)= 0.34123347100699979880664417166869481D-01 pw( 9)= 0.47126644724531756094751076593005203D-01 pw(10)= 0.65206569654682359265380728357008572D-01 pw(11)= 0.90252198579742822099518198813744744D-01 pw(12)= 0.12481812207643272140418893825548652D+00 pw(13)= 0.17237035227520038668196439463328275D+00 pw(14)= 0.23761696881618806722148067227743494D+00 pw(15)= 0.32696691109252817236452507243569941D+00 pw(16)= 0.44919654054160466696484020754729982D+00 pw(17)= 0.61648810596906235080169489216474494D+00 pw(18)= 0.84621818814094735945360350883771170D+00 pw(19)= 0.11644590806092632658493343351752018D+01 pw(20)= 0.16139465349437736570093587472680170D+01 pw(21)= 0.22758365152455412423280162288521126D+01 pw(22)= 0.33470981208584956190993329351906399D+01 pw(23)= 0.56005084488693785143169408072395655D+01 endif if(kn == 24) then px( 1)= 0.60287590220675965883655392550708199D-03 px( 2)= 0.32143351024974124786544026559297415D-02 px( 3)= 0.80739802149419819753399469823810803D-02 px( 4)= 0.15489662347070758196056101724102825D-01 px( 5)= 0.25976667055963881164895151817795199D-01 px( 6)= 0.40346714011175627204924600258024553D-01 px( 7)= 0.59830440001259694739569609351980817D-01 px( 8)= 0.86230308264184025703796753562250373D-01 px( 9)= 0.12210371973165121163051429982451776D+00 px(10)= 0.17099203191550984584070639962768156D+00 px(11)= 0.23772719534691312495205955287685848D+00 px(12)= 0.32885366959546582684337055007155510D+00 px(13)= 0.45320556860130100192674333119232671D+00 px(14)= 0.62268761188094067470211791701931515D+00 px(15)= 0.85332750333845602641945072572045710D+00 px(16)= 0.11667004858019451293051164929872329D+01 px(17)= 0.15918861333740258915421115101398109D+01 px(18)= 0.21682356132478165458928387387641436D+01 px(19)= 0.29494889123245918407695084553095216D+01 px(20)= 0.40104161879498382932676206134824540D+01 px(21)= 0.54588693247348625992863433295378994D+01 px(22)= 0.74614789122023638202247166496000371D+01 px(23)= 0.10312431148373425365575271866282924D+02 px(24)= 0.14705805275028081231659123827294642D+02 pw( 1)= 0.15514249847644583248110080072115634D-02 pw( 2)= 0.36981205611282502501592938773909080D-02 pw( 3)= 0.60714888966684178001398442739385021D-02 pw( 4)= 0.88442862964874279166007983229029862D-02 pw( 5)= 0.12262956109957475661400953934190561D-01 pw( 6)= 0.16679687959122678642462992762851947D-01 pw( 7)= 0.22585160392521754760445705422367202D-01 pw( 8)= 0.30637073979795749450832614038637313D-01 pw( 9)= 0.41694955770756579068288981525602823D-01 pw(10)= 0.56880053645721037701497821632682136D-01 pw(11)= 0.77671508906845583575064408093070968D-01 pw(12)= 0.10604093207274572585305524523636662D+00 pw(13)= 0.14462967696642788409146183249874326D+00 pw(14)= 0.19698231180562617603349065754159954D+00 pw(15)= 0.26786134570104304270817950330971854D+00 pw(16)= 0.36368625547483729027913381140943346D+00 pw(17)= 0.49317740444788268405884668163369343D+00 pw(18)= 0.66837334895456593354822252636195142D+00 pw(19)= 0.90640972513509685558875644594827397D+00 pw(20)= 0.12330418540439459719440490731353612D+01 pw(21)= 0.16907002256383886184087957665579435D+01 pw(22)= 0.23604873140910405927871490349730829D+01 pw(23)= 0.34403155641323731993571442081042100D+01 pw(24)= 0.57090593461669661084141390492124683D+01 endif if(kn == 25) then px( 1)= 0.57782426626576571901902524785967824D-03 px( 2)= 0.30777191085612843075800020147563616D-02 px( 3)= 0.77164086160794063370485387996841129D-02 px( 4)= 0.14761056704626219657716466804157254D-01 px( 5)= 0.24653875400014389680962462419049193D-01 px( 6)= 0.38083523913823039614894844760656273D-01 px( 7)= 0.56084067240729530165951958613013393D-01 px( 8)= 0.80159727346580499135438064461924847D-01 px( 9)= 0.11243339120217788148662085401543468D+00 px(10)= 0.15582715928119113928223955420169306D+00 px(11)= 0.21429698577498381337290048538797344D+00 px(12)= 0.29315054947238081211765761052065623D+00 px(13)= 0.39947904356246012931942329550682875D+00 px(14)= 0.54273750890918728697108592749256418D+00 px(15)= 0.73551917539468211697041027264605642D+00 px(16)= 0.99458876650351865510403034983347981D+00 px(17)= 0.13422725867611823095435983972364716D+01 px(18)= 0.18083631354696402035562158086478313D+01 px(19)= 0.24328170422327489041615980739248420D+01 px(20)= 0.32697931199298648820663632485790012D+01 px(21)= 0.43942247576362161609644700980578340D+01 px(22)= 0.59138559751958628054368604601307713D+01 px(23)= 0.79950700685028878658475844781145359D+01 px(24)= 0.10932212901976999668719864628273880D+02 px(25)= 0.15422270538187376197239585881075748D+02 pw( 1)= 0.14866196466384881027031457863846341D-02 pw( 2)= 0.35366057944120495831689126436344645D-02 pw( 3)= 0.57844969402891304739165399375745324D-02 pw( 4)= 0.83773253924994338826352544649181741D-02 pw( 5)= 0.11521432119169876731207250699755894D-01 pw( 6)= 0.15508119705558278186014992003540867D-01 pw( 7)= 0.20741213416907048628693122469214068D-01 pw( 8)= 0.27760968610727861118254402368893756D-01 pw( 9)= 0.37269537287121025856202203197461521D-01 pw(10)= 0.50172098341486540969354039874345299D-01 pw(11)= 0.67645050740466106776500656782887390D-01 pw(12)= 0.91234375023821592290664320838692913D-01 pw(13)= 0.12298569754451901426257783074280505D+00 pw(14)= 0.16561310646694880188580709432419945D+00 pw(15)= 0.22272153335996509389159575477724314D+00 pw(16)= 0.29910756989135904284632341805878551D+00 pw(17)= 0.40118169825940023204127855629976398D+00 pw(18)= 0.53759403804464314015326297165302822D+00 pw(19)= 0.72023661788993173698912869326221741D+00 pw(20)= 0.96601967120274407325842915516032939D+00 pw(21)= 0.13004209336797472935438387369012951D+01 pw(22)= 0.17656287674999046987390122872170472D+01 pw(23)= 0.24427681629137658222037012630588612D+01 pw(24)= 0.35307546103133160002458888441211917D+01 pw(25)= 0.58145056190411423438373377369723833D+01 endif if(kn == 26) then px( 1)= 0.55477997323631075943068059436768679D-03 px( 2)= 0.29524051251057578595813790584093855D-02 px( 3)= 0.73901342939831943165981049698675567D-02 px( 4)= 0.14101412872584234971190262785177463D-01 px( 5)= 0.23468728331528566192654626405819210D-01 px( 6)= 0.36081354457771003437927577005080307D-01 px( 7)= 0.52815777662090440120493976780463113D-01 px( 8)= 0.74938112557816762151465822385814066D-01 px( 9)= 0.10422602290395549848995179022541619D+00 px(10)= 0.14311379843177524483131355370021475D+00 px(11)= 0.19487526595566569453971371848061316D+00 px(12)= 0.26386679946717607062454498658707156D+00 px(13)= 0.35585463477981546153201478673425350D+00 px(14)= 0.47845228003668789580973663677048048D+00 px(15)= 0.64169971258466993649179145930192297D+00 px(16)= 0.85882779202859317392945336605019422D+00 px(17)= 0.11472706757497270472184438297710363D+01 px(18)= 0.15300218181930435465993945481075142D+01 px(19)= 0.20374900555366768284567833572011801D+01 px(20)= 0.27101363667403762213767958798451042D+01 px(21)= 0.36024461925895008266595796162422643D+01 px(22)= 0.47894509506391986224214442346207227D+01 px(23)= 0.63787680281602106661197309343576824D+01 px(24)= 0.85365750410497181159653468391328011D+01 px(25)= 0.11557476465733555694328533876083768D+02 px(26)= 0.16141471440934226918800792463390524D+02 pw( 1)= 0.14270457888511795867992646035078330D-02 pw( 2)= 0.33889549852374609060800978480342579D-02 pw( 3)= 0.55247507422590039192859514393700253D-02 pw( 4)= 0.79606058991690688534072920870913751D-02 pw( 5)= 0.10870893529433384055135393826453360D-01 pw( 6)= 0.14498723203402237674680094273702632D-01 pw( 7)= 0.19179116372035461554716799339102955D-01 pw( 8)= 0.25359449796805531683017831774564858D-01 pw( 9)= 0.33619093306389351199382063563600456D-01 pw(10)= 0.44698102947503307879411438578940957D-01 pw(11)= 0.59545498569788992362177569759542076D-01 pw(12)= 0.79391390756669405807121619168425508D-01 pw(13)= 0.10584364527942384492476511067473085D+00 pw(14)= 0.14101237929374191599558996117239049D+00 pw(15)= 0.18767097313836850144218059320809785D+00 pw(16)= 0.24946862930962964921754344345139933D+00 pw(17)= 0.33121906265157831801486301115689293D+00 pw(18)= 0.43930860961154203611926221969681638D+00 pw(19)= 0.58230770087411222173176311911927048D+00 pw(20)= 0.77196313761963428481446391672957021D+00 pw(21)= 0.10249770981257475300463739775919616D+01 pw(22)= 0.13665866627564720110102420582560601D+01 pw(23)= 0.18387931590238615303343058387625137D+01 pw(24)= 0.25228070818980592228138174960180006D+01 pw(25)= 0.36185923153701902774641344711352413D+01 pw(26)= 0.59170478659334870019465678075549678D+01 endif if(kn == 27) then px( 1)= 0.53351049035404632679792315747760926D-03 px( 2)= 0.28370305792687798355464055618059207D-02 px( 3)= 0.70911216690725917919709661777310467D-02 px( 4)= 0.13501035871356777604646936827660401D-01 px( 5)= 0.22399961695605187088994736400122990D-01 px( 6)= 0.34296092152256244946377676950669096D-01 px( 7)= 0.49938369643043464349412733250120371D-01 px( 8)= 0.70401007218931052290887962696404315D-01 px( 9)= 0.97184515439527403402719960641852663D-01 px(10)= 0.13233419679650342626453438780924062D+00 px(11)= 0.17858535768221430523992541052027664D+00 px(12)= 0.23955186967002279067082055689473205D+00 px(13)= 0.31997738343786115574032202180084953D+00 px(14)= 0.42606917808870858677237819912563285D+00 px(15)= 0.56593757336952698275709554352322422D+00 px(16)= 0.75017087050170008688238981674255895D+00 px(17)= 0.99258767627203407312800418206037430D+00 px(18)= 0.13112276119862221456283706350994460D+01 px(19)= 0.17296743945926671138206419268165977D+01 px(20)= 0.22788674435500397192690477951071238D+01 px(21)= 0.29996852862458953100640794763905730D+01 px(22)= 0.39468640965897806748062604397538661D+01 px(23)= 0.51954835049739316659023548298272390D+01 px(24)= 0.68530258860308177417175245026171396D+01 px(25)= 0.90855060116903171155308252608094055D+01 px(26)= 0.12187875689542501045614051917426613D+02 px(27)= 0.16863234023420842677139640506273211D+02 pw( 1)= 0.13720916834443970883055143999864006D-02 pw( 2)= 0.32534222826312859680330393960878445D-02 pw( 3)= 0.52884203958454954233826913886323010D-02 pw( 4)= 0.75861682815905379946822876423968075D-02 pw( 5)= 0.10295285639112777079908697606376495D-01 pw( 6)= 0.13620382459545697869019461721069283D-01 pw( 7)= 0.17841523884178755603525268045244929D-01 pw( 8)= 0.23331884086195134219312146516778989D-01 pw( 9)= 0.30573638051336305998992920739412241D-01 pw(10)= 0.40178513173563771124515253029295068D-01 pw(11)= 0.52921980029762362141777841892525060D-01 pw(12)= 0.69796141123370781915050562748149785D-01 pw(13)= 0.92082178946617789793924526199756695D-01 pw(14)= 0.12144364501581543284664137255263233D+00 pw(15)= 0.16004546398125829773973180676428128D+00 pw(16)= 0.21070793305215927164839501305159383D+00 pw(17)= 0.27711057981819535787363684480367458D+00 pw(18)= 0.36407033983503565406434335329539225D+00 pw(19)= 0.47793795110360227457939282572737921D+00 pw(20)= 0.62719851165950099532441318332470642D+00 pw(21)= 0.82345785449976155240467438227528273D+00 pw(22)= 0.10832282284259041619866566987699138D+01 pw(23)= 0.14315401678117573067846471990768551D+01 pw(24)= 0.19102558501900861570470238950653852D+01 pw(25)= 0.26007234476536547511161089599236255D+01 pw(26)= 0.37039892290540711004993184577181103D+01 pw(27)= 0.60168669305235587630364842700538762D+01 endif if(kn == 28) then px( 1)= 0.51381795837439443363513212680713947D-03 px( 2)= 0.27304457410704199858650659828620367D-02 px( 3)= 0.68160137769119765426643490207146340D-02 px( 4)= 0.12952008943105054557760398423212956D-01 px( 5)= 0.21430556623995591107026232001066913D-01 px( 6)= 0.32693077435416129189765100617149847D-01 px( 7)= 0.47384339361452651219408943088094832D-01 px( 8)= 0.66422538658869906464895332297645726D-01 px( 9)= 0.91083609265701992171879031038032271D-01 px(10)= 0.12309931515680468843361103443044334D+00 px(11)= 0.16477454361350713713658223760718724D+00 px(12)= 0.21913585560877712250760133646822826D+00 px(13)= 0.29012664768975497883815066595179815D+00 px(14)= 0.38286487674840579443374001038670456D+00 px(15)= 0.50398058179729621330814443966676445D+00 px(16)= 0.66205451410726746024107068348273274D+00 px(17)= 0.86818664253955900521872813145997494D+00 px(18)= 0.11367350670636899400604869200366967D+01 px(19)= 0.14862849200104679887431662518488448D+01 px(20)= 0.19409402276831122951996033127610769D+01 px(21)= 0.25320952507423009788362491203678215D+01 px(22)= 0.33009718613493033820591483341014688D+01 px(23)= 0.43024948141012255149771188379035923D+01 px(24)= 0.56117545045133971321428621533897157D+01 px(25)= 0.73360976078470116280524716610880778D+01 px(26)= 0.96414187592042593009284671180300365D+01 px(27)= 0.12823096392169689557014539066503465D+02 px(28)= 0.17587400071042305461725873529323834D+02 pw( 1)= 0.13212378315760757100801294124815478D-02 pw( 2)= 0.31285477801160114283501913408130908D-02 pw( 3)= 0.50723762615025144279692888527822532D-02 pw( 4)= 0.72476698125814896247817149986171532D-02 pw( 5)= 0.97820955598317266921336611328577874D-02 pw( 6)= 0.12849233584715652412922486858932270D-01 pw( 7)= 0.16684914458309663575212478712400069D-01 pw( 8)= 0.21602517467719514930691067702478109D-01 pw( 9)= 0.28006326728639319667000527469785398D-01 pw(10)= 0.36406794940307839233444412699072219D-01 pw(11)= 0.47444873633013210207704765440613480D-01 pw(12)= 0.61930727493054842346818886062879310D-01 pw(13)= 0.80898273560459582900261577117872215D-01 pw(14)= 0.10567594748292560400210313567244803D+00 pw(15)= 0.13797620661979101239766714101470269D+00 pw(16)= 0.18000947429659496345933986602370689D+00 pw(17)= 0.23463186153608726981379368239281040D+00 pw(18)= 0.30554132794139847744947603213040709D+00 pw(19)= 0.39754682244155206328794798554812257D+00 pw(20)= 0.51695511158335980560554454196568031D+00 pw(21)= 0.67216328370835447637864341433166332D+00 pw(22)= 0.87464250694849374310652866430377750D+00 pw(23)= 0.11407332853853718344895028360165344D+01 pw(24)= 0.14952907674277354153396565164371127D+01 pw(25)= 0.19800794802566744638917545875047599D+01 pw(26)= 0.26766284602650483548086237399782999D+01 pw(27)= 0.37870913379223214170502998382833988D+01 pw(28)= 0.61141264493435815963177300026057897D+01 endif if(kn == 29) then px( 1)= 0.49553294523216557706121043094899937D-03 px( 2)= 0.26316733478032430241054271443133571D-02 px( 3)= 0.65619932921719095950945647167842097D-02 px( 4)= 0.12447798146998465679635850497317547D-01 px( 5)= 0.20546725218853503579585565380355127D-01 px( 6)= 0.31244723477287375693064121565353181D-01 px( 7)= 0.45100744250336127000529420647899915D-01 px( 8)= 0.62905104337181109718071876082818174D-01 px( 9)= 0.85750236217882191338049895922209411D-01 px(10)= 0.11511276616778913843095284495474961D+00 px(11)= 0.15294975780371902992191410154541288D+00 px(12)= 0.20181754709239365590998602589064153D+00 px(13)= 0.26502522465295890912360438565915637D+00 px(14)= 0.34683572458174845871862351357320832D+00 px(15)= 0.45272795494425557401215215391241853D+00 px(16)= 0.58973560996706034541847942850272405D+00 px(17)= 0.76688297098562182278932098742313991D+00 px(18)= 0.99574549679776398032257261690761656D+00 px(19)= 0.12911746195797983348858102746352939D+01 px(20)= 0.16722452518287396697078251913438203D+01 px(21)= 0.21635184617418031866723236843209620D+01 px(22)= 0.27967767483991669703409180904294707D+01 px(23)= 0.36135221397956750546277975652240522D+01 px(24)= 0.46688173594398401975825823496477303D+01 px(25)= 0.60377360285854709978780788792051344D+01 px(26)= 0.78274940573494599108741305430804683D+01 px(27)= 0.10203907613754336363839677845176062D+02 px(28)= 0.13462852450631673420328416214301979D+02 px(29)= 0.18313825184349771602172383716912527D+02 pw( 1)= 0.12740401404642070584625642978316674D-02 pw( 2)= 0.30131005567070877653374960845857871D-02 pw( 3)= 0.48740340828768558996439695359657849D-02 pw( 4)= 0.69399937174499322748248258405693356D-02 pw( 5)= 0.93214421069590292260830707831625273D-02 pw( 6)= 0.12166736320428934613437189621950636D-01 pw( 7)= 0.15675841191975760517355581582896129D-01 pw( 8)= 0.20113588991116143831392394792507242D-01 pw( 9)= 0.25821196242227502811986031677074846D-01 pw(10)= 0.33228090412405890048263783552877789D-01 pw(11)= 0.42869421776728397919368187941044920D-01 pw(12)= 0.55414351585478714766063918835679369D-01 pw(13)= 0.71707159949828379722440698604318357D-01 pw(14)= 0.92821391683596645191185627202531776D-01 pw(15)= 0.12012815275736363503642593112420207D+00 pw(16)= 0.15538195214533728663259981412132171D+00 pw(17)= 0.20083006704520997993532092391882379D+00 pw(18)= 0.25935464058941676571399243604292685D+00 pw(19)= 0.33466206352796625147483719389400201D+00 pw(20)= 0.43154442816926686793937626854331538D+00 pw(21)= 0.55625869020489676787739935371459343D+00 pw(22)= 0.71711352998990444136642620781136560D+00 pw(23)= 0.92545309501307835297306650109719589D+00 pw(24)= 0.11974638996261713170731294345952752D+01 pw(25)= 0.15578539402639460936307650070163272D+01 pw(26)= 0.20483259849497670771611527406588667D+01 pw(27)= 0.27506256539950821112799212513803514D+01 pw(28)= 0.38680317406459942528573299847997115D+01 pw(29)= 0.62089749987608497692655462325987093D+01 endif if(kn == 30) then px( 1)= 0.47850950616663001797979108558563715D-03 px( 2)= 0.25398771556977649765987433184628366D-02 px( 3)= 0.63266767276005636636918971079049107D-02 px( 4)= 0.11982958698830863481679603697851263D-01 px( 5)= 0.19737172990592845187334346934200923D-01 px( 6)= 0.29928809539955562795388150514477224D-01 px( 7)= 0.43045554614365273736449489448924963D-01 px( 8)= 0.59772102008795894644542468648119854D-01 px( 9)= 0.81049794509547598102960610576252333D-01 px(10)= 0.10814588049834038786751975710018494D+00 px(11)= 0.14273357759635461536908362003919156D+00 px(12)= 0.18698857852398412902900671067259807D+00 px(13)= 0.24371127323293364985980734512310093D+00 px(14)= 0.31648527240822183351218895583590417D+00 px(15)= 0.40988303161683259239808922937843934D+00 px(16)= 0.52973043830387724896707606257507982D+00 px(17)= 0.68344507067026327204085106743008657D+00 px(18)= 0.88046769972296521320190133680773247D+00 px(19)= 0.11328140045719997686900182451437385D+01 px(20)= 0.14557849987988940136735253178131959D+01 px(21)= 0.18688939211845819607060281336643708D+01 px(22)= 0.23971019483057447245002052718973892D+01 px(23)= 0.30725214791534315669485745292475362D+01 px(24)= 0.39368810885201871521056281051541589D+01 px(25)= 0.50453405183264296277555982679398449D+01 px(26)= 0.64729369863961542161639397127927023D+01 px(27)= 0.83267646024511909496921957165518850D+01 px(28)= 0.10772601108679545696397581453580679D+02 px(29)= 0.14106882472397927743465848536293191D+02 px(30)= 0.19042377139722396576925840568797290D+02 pw( 1)= 0.12301166672602858132749403305585138D-02 pw( 2)= 0.29060349388917145213464128010319648D-02 pw( 3)= 0.46912396989831005493100286944698875D-02 pw( 4)= 0.66589658633863613568668981891460303D-02 pw( 5)= 0.89054272701749525193189873717149483D-02 pw( 6)= 0.11558310934603853176421212815818196D-01 pw( 7)= 0.14788296604172157875123267577237353D-01 pw( 8)= 0.18820536178193913710320280585533146D-01 pw( 9)= 0.23944736371120032144351948458331453D-01 pw(10)= 0.30524720054213913983988370110313231D-01 pw(11)= 0.39011278230203159299747340391501401D-01 pw(12)= 0.49962838489107032100208706917355628D-01 pw(13)= 0.64076419786867156599743093793566683D-01 pw(14)= 0.82229278957901320956487642041730955D-01 pw(15)= 0.10553162871986467114052832148689872D+00 pw(16)= 0.13539231869402525697097331669289294D+00 pw(17)= 0.17360130147051396517985693386136263D+00 pw(18)= 0.22243486135302704942601690670544171D+00 pw(19)= 0.28479267765730766074850970825016903D+00 pw(20)= 0.36438127580923131688892141299329716D+00 pw(21)= 0.46596902265107476258412993277856600D+00 pw(22)= 0.59575928418635779724375261556025579D+00 pw(23)= 0.76197365269330802425420319974692784D+00 pw(24)= 0.97583770654840390135150485526335360D+00 pw(25)= 0.12534009762825410047987823857212526D+01 pw(26)= 0.16192497318165861534514297610388291D+01 pw(27)= 0.21150559758743170143427430064927639D+01 pw(28)= 0.28228114202692982120171862876336191D+01 pw(29)= 0.39469320964297990895048746179623006D+01 pw(30)= 0.63015479148815916165232775496615043D+01 endif if(kn == 31) then px( 1)= 0.46262124155980990900658158435387435D-03 px( 2)= 0.24543371823976573134043990222488764D-02 px( 3)= 0.61080328529962740945375030974273550D-02 px( 4)= 0.11552913696384311289392080456928671D-01 px( 5)= 0.18992554406021427042667932899509712D-01 px( 6)= 0.28727239767175649142836330874634688D-01 px( 7)= 0.41185025043396586435794925588583817D-01 px( 8)= 0.56962729337650718045473296117050346D-01 px( 9)= 0.76876408592321896648696565625767740D-01 px(10)= 0.10202017613750426995368814592543654D+00 px(11)= 0.13383358226439616664891093380483172D+00 px(12)= 0.17418111785696519564699242954723688D+00 px(13)= 0.22545079288954335283945305080525555D+00 px(14)= 0.29068039334037578871072959727864135D+00 px(15)= 0.37372028651206644042103206921271373D+00 px(16)= 0.47944207171169672906363477630137984D+00 px(17)= 0.61400401892256187595697112035275391D+00 px(18)= 0.78518739405456531463788153132800130D+00 px(19)= 0.10028226298243299869022545200635749D+01 px(20)= 0.12793315955946422764804637028085576D+01 px(21)= 0.16304237404723823714635864157191701D+01 px(22)= 0.20760033968995280036753528016386266D+01 px(23)= 0.26413808369702250796358745676110842D+01 px(24)= 0.33589474379157213932868619266312477D+01 px(25)= 0.42706130083047912404753160217494471D+01 px(26)= 0.54316014237021642862351869609909389D+01 px(27)= 0.69169001596879784406900118967237735D+01 px(28)= 0.88334933035422052410960663437339313D+01 px(29)= 0.11347158219793510037091924273351551D+02 px(30)= 0.14754946949122040546764367410101515D+02 px(31)= 0.19772934489331283651619534072783573D+02 pw( 1)= 0.11891370745192323541501363233610476D-02 pw( 2)= 0.28064565117632969596616229162402416D-02 pw( 3)= 0.45221820039177658202628966334564400D-02 pw( 4)= 0.64011462699419650278998414745094563D-02 pw( 5)= 0.85276672843451997393681235521893987D-02 pw( 6)= 0.11012361472143567538937306026897082D-01 pw( 7)= 0.14001834101185433452944676115710984D-01 pw( 8)= 0.17688602970920088694526112750101821D-01 pw( 9)= 0.22319993264776239711478935025076064D-01 pw(10)= 0.28206159264133299993412221361362783D-01 pw(11)= 0.35729779624362463483758438125027756D-01 pw(12)= 0.45361209930192015109636119041934318D-01 pw(13)= 0.57681745959882977997939097436077625D-01 pw(14)= 0.73415730766069123013128503531856238D-01 pw(15)= 0.93471597750154348901340915093546613D-01 pw(16)= 0.11899278980540690788248491553604027D+00 pw(17)= 0.15142094037875549556146133150023155D+00 pw(18)= 0.19257526453331204560446543583285304D+00 pw(19)= 0.24475404687248924789069417791551804D+00 pw(20)= 0.31086721331790994056051025981812504D+00 pw(21)= 0.39461463811187169999440896691515521D+00 pw(22)= 0.50073578853625257469356342726971100D+00 pw(23)= 0.63537831862561035023942323431330555D+00 pw(24)= 0.80667931860754124288487929852367162D+00 pw(25)= 0.10257546571965496140352844249415068D+01 pw(26)= 0.13085329420794059702124934248171024D+01 pw(27)= 0.16795015057251400866456256943483557D+01 pw(28)= 0.21803283205051475095028864283497279D+01 pw(29)= 0.28932755231818831561701787327064654D+01 pw(30)= 0.40239038808605675586573707403263756D+01 pw(31)= 0.63919688446180182394784276398611383D+01 endif if(kn == 32) then px( 1)= 0.44775812457284018024389459757135253D-03 px( 2)= 0.23744300256081390660731331947131448D-02 px( 3)= 0.59043190530701947087959015074527131D-02 px( 4)= 0.11153785163059738085602585751236982D-01 px( 5)= 0.18305065328015338438613004118489460D-01 px( 6)= 0.27625127970368047372371104083117018D-01 px( 7)= 0.39491775186977265606198670142306198D-01 px( 8)= 0.54428213199640073895058009136940445D-01 px( 9)= 0.73145916598392207837439901430911881D-01 px(10)= 0.96594842317146387626737019235932073D-01 px(11)= 0.12602067507135613816122919853447211D+00 px(12)= 0.16303119243744080803051027229475087D+00 px(13)= 0.20967680096838206807696535069330795D+00 px(14)= 0.26855214787001775388966483767701730D+00 px(15)= 0.34292617657317298468348748407414908D+00 px(16)= 0.43690813207789007326976756359678361D+00 px(17)= 0.55565789063347173772943038765658058D+00 px(18)= 0.70565099753808518503172131364185913D+00 px(19)= 0.89501204411614229330337167600565325D+00 px(20)= 0.11339348063954267650829490706793417D+01 px(21)= 0.14352147947875517113501672147412666D+01 px(22)= 0.18149314500489324404656062560197686D+01 px(23)= 0.22933370525154514327968223407435420D+01 px(24)= 0.28960454333191297694038803298227801D+01 px(25)= 0.36556826421582258456995650363192002D+01 px(26)= 0.46143015669042314317688786912840126D+01 px(27)= 0.58271640488452237241101113536108246D+01 px(28)= 0.73691994618471152327249495515078891D+01 px(29)= 0.93472955333283431319402613994267131D+01 px(30)= 0.11927265101386731589772177284607045D+02 px(31)= 0.15406825810545224143258580731663182D+02 px(32)= 0.20505385359315843909738804845728816D+02 pw( 1)= 0.11508141693310289431516002902194819D-02 pw( 2)= 0.27135954170378174829279299706770743D-02 pw( 3)= 0.43653263744209382080072687149869796D-02 pw( 4)= 0.61636735125379730211346708661816263D-02 pw( 5)= 0.81829488620066496094938528145972129D-02 pw( 6)= 0.10519566782024470065554644097490174D-01 pw( 7)= 0.13300211432891686360240172032295580D-01 pw( 8)= 0.16690405167066082789755182863245534D-01 pw( 9)= 0.20902378399561394483383583702025306D-01 pw(10)= 0.26201993681677797113818409392334214D-01 pw(11)= 0.32916309597556149563466321558626500D-01 pw(12)= 0.41444783686249708806280965671571355D-01 pw(13)= 0.52276724501596285458733044616038927D-01 pw(14)= 0.66016045915514602434595691235181054D-01 pw(15)= 0.83413404413409668999356206612085646D-01 pw(16)= 0.10540610055778962043592758135111163D+00 pw(17)= 0.13316716078519390466674733202657980D+00 pw(18)= 0.16816620873421840783275153829642565D+00 pw(19)= 0.21224605690896243222098764241728942D+00 pw(20)= 0.26772081279710238967904075331055395D+00 pw(21)= 0.33750446543867324459731453510204593D+00 pw(22)= 0.42528477444911122706373139673310844D+00 pw(23)= 0.53576855465657922120503664249148172D+00 pw(24)= 0.67504694124786279657121038348068956D+00 pw(25)= 0.85117601343595945001255999545786031D+00 pw(26)= 0.10751709034800588277387396074134080D+01 pw(27)= 0.13628543051087082785935353862196062D+01 pw(28)= 0.17386349660199069072599128814460612D+01 pw(29)= 0.22441998697757930470131299950344772D+01 pw(30)= 0.29621015955004271568195551910771395D+01 pw(31)= 0.40990494779803030065007758020292907D+01 pw(32)= 0.64803510743879183341918928981358705D+01 endif if(kn == 33) then px( 1)= 0.43382392840086627333673371770410791D-03 px( 2)= 0.22996130762133902306219348170634844D-02 px( 3)= 0.57140311482877757226936621231899489D-02 px( 4)= 0.10782263460575904849778834680881905D-01 px( 5)= 0.17668133941325186930637700801463696D-01 px( 6)= 0.26610114005745400437311454869685139D-01 px( 7)= 0.37943370827578419250767127256762961D-01 px( 8)= 0.52129041240975080218154665697626616D-01 px( 9)= 0.69790754616119288011923380403081974D-01 px(10)= 0.91757677110053287920628073294896820D-01 px(11)= 0.11911351898045213836878312985804824D+00 px(12)= 0.15325258383592569039382713986292282D+00 px(13)= 0.19594640045311118270956256575773479D+00 px(14)= 0.24942637714448661140410427601352782D+00 px(15)= 0.31648861015431273270737411206235176D+00 px(16)= 0.40062704984338027141229486836727772D+00 px(17)= 0.50620162303052368324000671362943743D+00 px(18)= 0.63864913663861731335041615079256755D+00 px(19)= 0.80474696130540033570426941368276095D+00 px(20)= 0.10129427268888740212312948144945017D+01 px(21)= 0.12737679814899102853785194013828910D+01 px(22)= 0.16003609719649203492661497770183358D+01 px(23)= 0.20091354103290292174609108669156369D+01 px(24)= 0.25206522780436439397099624663858851D+01 px(25)= 0.31607884518783084627961967518655955D+01 px(26)= 0.39623662204110196024719874486085284D+01 px(27)= 0.49675495548589556752790709024651368D+01 px(28)= 0.62316176745314993859698590995521575D+01 px(29)= 0.78294374119411180631665027515007813D+01 px(30)= 0.98678149766403120157427026982285647D+01 px(31)= 0.12512632243648644312040507648114218D+02 px(32)= 0.16062316312799007384705365546800182D+02 px(33)= 0.21239626413140571003413447643564263D+02 pw( 1)= 0.11148970595521907012019732812607055D-02 pw( 2)= 0.26267851653678976569258782421234610D-02 pw( 3)= 0.42193631422457547168621098688321193D-02 pw( 4)= 0.59441470797152969047545135707624789D-02 pw( 5)= 0.78669738899974671911070000143132306D-02 pw( 6)= 0.10072359597590157564525137294462730D-01 pw( 7)= 0.12670399361862170180506056379944600D-01 pw( 8)= 0.15804160264438711138334353671976234D-01 pw( 9)= 0.19656646222033544724001127769742948D-01 pw(10)= 0.24456891716604317647752096255377977D-01 pw(11)= 0.30486078976025291042502816433302855D-01 pw(12)= 0.38085942822052281180984432235900915D-01 pw(13)= 0.47671859587250413816889365465789990D-01 pw(14)= 0.59751905747580346721160295363733596D-01 pw(15)= 0.74952101551419066714546625345670463D-01 pw(16)= 0.94047940645329027189027157260871966D-01 pw(17)= 0.11800297644299036213439491803576584D+00 pw(18)= 0.14801615944289654934244517014490498D+00 pw(19)= 0.18558059212548173745682851099099352D+00 pw(20)= 0.23255756871893273043599614945440298D+00 pw(21)= 0.29127163202367449192902938057774536D+00 pw(22)= 0.36463564879320343679994202632934432D+00 pw(23)= 0.45632094652154984485718193074718634D+00 pw(24)= 0.57099911532700834474505095568484057D+00 pw(25)= 0.71470499479041253227766745277939393D+00 pw(26)= 0.89541776346343118676696712049315123D+00 pw(27)= 0.11240606917291058823868093321319567D+01 pw(28)= 0.14163644716761897658439794410119483D+01 pw(29)= 0.17966773927205272792519385809395869D+01 pw(30)= 0.23067252939728463992747791116176630D+01 pw(31)= 0.30293676082841986853392483236331039D+01 pw(32)= 0.41724631327442166841549815997399232D+01 pw(33)= 0.65667986737889171343050053820031099D+01 endif if(kn == 34) then px( 1)= 0.42073412472404638893756652613349609D-03 px( 2)= 0.22294117501223585040813842121338791D-02 px( 3)= 0.55358634424631592178894736933123541D-02 px( 4)= 0.10435505221909818911938312253494801D-01 px( 5)= 0.17076183522530106340715524871890215D-01 px( 6)= 0.25671846892716699934599581849440412D-01 px( 7)= 0.36521262393930458152775347026295878D-01 px( 8)= 0.50032905506982571537052624490236219D-01 px( 9)= 0.66756179329851771946428938115562858D-01 px(10)= 0.87418440517600995276435533200107158D-01 px(11)= 0.11296720871152482793171861979004167D+00 px(12)= 0.14461798209060507185491668160548863D+00 px(13)= 0.18391003445626398421131159916752177D+00 px(14)= 0.23277438392452600064632190536358711D+00 px(15)= 0.29361900416298607661742971283165405D+00 px(16)= 0.36943648509469646191303516064166821D+00 px(17)= 0.46393948817397095233405427748578045D+00 px(18)= 0.58173003909628716647282591793935082D+00 px(19)= 0.72851013492593350843955115700236997D+00 px(20)= 0.91134335818633179015533214138153748D+00 px(21)= 0.11389803746065945729570613409749246D+01 px(22)= 0.14222658613929989350760708533653619D+01 px(23)= 0.17746516415212834951524711400325322D+01 px(24)= 0.22128526659161258391280177907354742D+01 px(25)= 0.27577030475922356628315880749135163D+01 px(26)= 0.34353067716163467499117583277012187D+01 px(27)= 0.42786491225875840394307069342936437D+01 px(28)= 0.53299784436903981664272138662385839D+01 px(29)= 0.66445753694632339412682622877981687D+01 px(30)= 0.82972428161435530717136911066799313D+01 px(31)= 0.10394720964339982803669830220514570D+02 px(32)= 0.13102991988894450504911092547924425D+02 px(33)= 0.16721231207604090231249152699717947D+02 px(34)= 0.21975561953387058269749184334695681D+02 pw( 1)= 0.10811655766145357018010507192110778D-02 pw( 2)= 0.25454456692504695230374260776656758D-02 pw( 3)= 0.40831672721796992810291858236827121D-02 pw( 4)= 0.57405373464649057612542381878716024D-02 pw( 5)= 0.75761674957710259616551754950037804D-02 pw( 6)= 0.96645393330211172110854747921485211D-02 pw( 7)= 0.12101849132180839391980047456808267D-01 pw( 8)= 0.15012385166203703798856896165367048D-01 pw( 9)= 0.18554685664439102794960148200939741D-01 pw(10)= 0.22926965460919156862511787954586100D-01 pw(11)= 0.28372234446912034618472293586026471D-01 pw(12)= 0.35184737546237040728179133891634893D-01 pw(13)= 0.43719795721391424383284929004984363D-01 pw(14)= 0.54408450285118084483187831793976080D-01 pw(15)= 0.67777311678116535143958157494852949D-01 pw(16)= 0.84473623053475603301350103260219498D-01 pw(17)= 0.10529589998535694380806537413267952D+00 pw(18)= 0.13123120457466970233581600829200986D+00 pw(19)= 0.16350086670529523991639926152378893D+00 pw(20)= 0.20361729924366521691008806803033027D+00 pw(21)= 0.25345571161549014721855872141678839D+00 pw(22)= 0.31534642949457072923890964012293452D+00 pw(23)= 0.39219690177745437575400107500840528D+00 pw(24)= 0.48765869057533013816866773942301700D+00 pw(25)= 0.60636656060951114856441189594293935D+00 pw(26)= 0.75430007270808930870580918261471173D+00 pw(27)= 0.93936601064002840188234207354112438D+00 pw(28)= 0.11724044094922051599035401593357573D+01 pw(29)= 0.14690667743714044794229623979582298D+01 pw(30)= 0.18536570456604450828475022635489700D+01 pw(31)= 0.23679569977291335149484204767547713D+01 pw(32)= 0.30951463106197815052582135293694448D+01 pw(33)= 0.42442317841513325464351782732665369D+01 pw(34)= 0.66514074844570206292427905989816795D+01 endif if(kn == 35) then px( 1)= 0.40841415548604021515920964002399699D-03 px( 2)= 0.21634090823285078411638264192646176D-02 px( 3)= 0.53686766256969092483856645653707325D-02 px( 4)= 0.10111052749147679432588829471203234D-01 px( 5)= 0.16524448303260385083329478751404387D-01 px( 6)= 0.24801589512429266354562963867459375D-01 px( 7)= 0.35209981971294629902224557027954734D-01 px( 8)= 0.48113158246267914322027983645621137D-01 px( 9)= 0.63997447579595411241665965285069235D-01 px(10)= 0.83503921106837065850088749934585509D-01 px(11)= 0.10746492183189159858451002479100191D+00 px(12)= 0.13694520147247420040072594436271529D+00 px(13)= 0.17328916996785784591140856733770825D+00 px(14)= 0.21817740121438829093802932764502942D+00 px(15)= 0.27369653832797779961249433698659440D+00 px(16)= 0.34242699906149186851837117836266744D+00 px(17)= 0.42755291549796611179923030387067599D+00 px(18)= 0.53299909554182158428637150014155340D+00 px(19)= 0.66360070964681593124502281725999578D+00 px(20)= 0.82531292882837242125696121653082133D+00 px(21)= 0.10254699397214209538105608220109125D+01 px(22)= 0.12731058972360937198805843671213415D+01 px(23)= 0.15793550240911338542780101952325349D+01 px(24)= 0.19579553515472245197868811537799063D+01 px(25)= 0.24258926480980508600328748991363509D+01 px(26)= 0.30042420249956940401285542677229005D+01 px(27)= 0.37193027838966272865717795755051677D+01 px(28)= 0.46041945352246751335584778757254638D+01 px(29)= 0.57012278072022800341169042054436900D+01 px(30)= 0.70656725104389005421933634969655744D+01 px(31)= 0.87722686454754899579881428713693370D+01 px(32)= 0.10927706100825575628425432470397431D+02 px(33)= 0.13698096354347216687650292593862930D+02 px(34)= 0.17383397148588794631800252981912492D+02 px(35)= 0.22713103140185533251728138884147593D+02 pw( 1)= 0.10494256988526777696106600190246748D-02 pw( 2)= 0.24690695403322712989700976425347600D-02 pw( 3)= 0.39557664886781607598248979520245308D-02 pw( 4)= 0.55511159047852988512979064225320046D-02 pw( 5)= 0.73075320876513631863948214849392405D-02 pw( 6)= 0.92909810870320629850049703997767543D-02 pw( 7)= 0.11585945487945439996692114097667348D-01 pw( 8)= 0.14300927726198362348901143963929085D-01 pw( 9)= 0.17573886933485282780152536853558582D-01 pw(10)= 0.21577101857175674214083208317224449D-01 pw(11)= 0.26521578525384159056539231969282277D-01 pw(12)= 0.32662117530178998186687978899517756D-01 pw(13)= 0.40304760583700356024679394121082348D-01 pw(14)= 0.49818024406493848323885700890345396D-01 pw(15)= 0.61648498278387927702353594142316029D-01 pw(16)= 0.76340842519971003579540175209086024D-01 pw(17)= 0.94562313841812711417919902804637839D-01 pw(18)= 0.11713243611448668905011510723033361D+00 pw(19)= 0.14505903302187588429490257418340878D+00 pw(20)= 0.17958246056420660249030476513346108D+00 pw(21)= 0.22223064193925674596660827103307295D+00 pw(22)= 0.27488866495140173131704069241445894D+00 pw(23)= 0.33988865913831065785773004058455433D+00 pw(24)= 0.42012914561889293897263514396102618D+00 pw(25)= 0.51923942630667304009247143973261919D+00 pw(26)= 0.64181663147268449329914151912099321D+00 pw(27)= 0.79378665914719288398623606417929212D+00 pw(28)= 0.98298862630823929161929765759110274D+00 pw(29)= 0.12201876100804632086249205242578178D+01 pw(30)= 0.15209676736777719585360185637783971D+01 pw(31)= 0.19096027011177832508222236236206329D+01 pw(32)= 0.24279450923678125311674033890233300D+01 pw(33)= 0.31595056381881229211813965570928908D+01 pw(34)= 0.43144357961085612515538420099471387D+01 pw(35)= 0.67342659787038143488625655899472123D+01 endif if(kn == 36) then px( 1)= 0.39679800273035937692456569764529929D-03 px( 2)= 0.21012371857514574429814634636370868D-02 px( 3)= 0.52114717733736355471865173697424917D-02 px( 4)= 0.98067697534794548776488857189272695D-02 px( 5)= 0.16008829048610610861085787414831567D-01 px( 6)= 0.23991913025422802197171963117636148D-01 px( 7)= 0.33996529414545629919769339896568646D-01 px( 8)= 0.46347640349961743012995653495638967D-01 px( 9)= 0.61477688475695067453069318914244194D-01 px(10)= 0.79954234262530625440149978974196142D-01 px(11)= 0.10251169364078550312390054066216880D+00 px(12)= 0.13008697511618887542147079025562156D+00 px(13)= 0.16385989560749921185926347303565033D+00 px(14)= 0.20530066324396880599546126878370330D+00 px(15)= 0.25622775706568656239933185280550197D+00 px(16)= 0.31887992047473434247218676095668498D+00 px(17)= 0.39600601270766777602081700578327931D+00 px(18)= 0.49097660869784478263571961512354166D+00 px(19)= 0.60792179107232897416464078744063313D+00 px(20)= 0.75190061348713360022081088193051979D+00 px(21)= 0.92910925563205451252801298079690580D+00 px(22)= 0.11471370551908310980346755006364606D+01 px(23)= 0.14152827011474745738425470935393175D+01 px(24)= 0.17449475260933662620173991491940897D+01 px(25)= 0.21501302020535220058465237512287759D+01 px(26)= 0.26480593984665582591226977578025315D+01 px(27)= 0.32600222787200297912657865580064671D+01 px(28)= 0.40124854077257132134482639353308378D+01 px(29)= 0.49386780680939238173283121803851184D+01 px(30)= 0.60809546519546778854776584514884910D+01 px(31)= 0.74945653594942201002132544001003708D+01 px(32)= 0.92541900969385753944715137178141946D+01 px(33)= 0.11466484149563363201326491294746713D+02 px(34)= 0.14297715117728357842590639672319382D+02 px(35)= 0.18048653298710078396919876650411551D+02 px(36)= 0.23452167308415151157069277254133065D+02 pw( 1)= 0.10195057714700151361278566695804673D-02 pw( 2)= 0.23972109360881477362914694357034945D-02 pw( 3)= 0.38363158447342177123425836110343923D-02 pw( 4)= 0.53744010839767438647013296257593752D-02 pw( 5)= 0.70585351522933460613686733697482296D-02 pw( 6)= 0.89474146486528988019752703037120466D-02 pw( 7)= 0.11115594177177423398237576162176609D-01 pw( 8)= 0.13658239363054657454269471936854599D-01 pw( 9)= 0.16695920500566358906782047930663171D-01 pw(10)= 0.20378981713905551927970998274789754D-01 pw(11)= 0.24891420496520210335919294073059272D-01 pw(12)= 0.30454995468399097263969267647541847D-01 pw(13)= 0.37334924544188163864246559109559135D-01 pw(14)= 0.45848499525488242728225859778156080D-01 pw(15)= 0.56377323577091624057815057252308315D-01 pw(16)= 0.69383296835632602012769529156119272D-01 pw(17)= 0.85428366438632838815674340562473751D-01 pw(18)= 0.10519836473842813187954075539197942D+00 pw(19)= 0.12953172788969281249628541902884322D+00 pw(20)= 0.15945437502320699870857044488189859D+00 pw(21)= 0.19622256830996434214924230362068723D+00 pw(22)= 0.24137631349243177937384183525770442D+00 pw(23)= 0.29680703930305420431908018221051720D+00 pw(24)= 0.36484530976842630509122266207581834D+00 pw(25)= 0.44837789623740881716704249442275046D+00 pw(26)= 0.55101005426642996452229825498001978D+00 pw(27)= 0.67730110868383751051906031936646973D+00 pw(28)= 0.83312535104283525888024444527691004D+00 pw(29)= 0.10262590489160128936079715697075387D+01 pw(30)= 0.12674001847129782122095271537034034D+01 pw(31)= 0.15720761022006313395632370048802129D+01 pw(32)= 0.19645432933987013230055443656345311D+01 pw(33)= 0.24867374093856289898664232230940440D+01 pw(34)= 0.32225090907915900251361180974071379D+01 pw(35)= 0.43831496004036045715808964702697293D+01 pw(36)= 0.68154560080748566632769223367688120D+01 endif if(kn == 37) then px( 1)= 0.38582699810911109314412610582600285D-03 px( 2)= 0.20425701942290192876130910611009103D-02 px( 3)= 0.50633691210660737148684629408797998D-02 px( 4)= 0.95207896708291718422773083291578438D-02 px( 5)= 0.15525778682735758953134513377993514D-01 px( 6)= 0.23236458251477143892762148491421503D-01 px( 7)= 0.32869898315502381365977793756399700D-01 px( 8)= 0.44717783821182009237592740999277480D-01 px( 9)= 0.59166282378413474386219652173387790D-01 px(10)= 0.76720016407611302507577044991006663D-01 px(11)= 0.98029725568599136751267367485311366D-01 px(12)= 0.12392331356464118155739304688774820D+00 px(13)= 0.15544072437387706131982741857227680D+00 px(14)= 0.19387425549171156055801006554376491D+00 px(15)= 0.24081693190720646255336253748180444D+00 px(16)= 0.29822205905402883495704063798959865D+00 px(17)= 0.36847715057286422135924881742734873D+00 px(18)= 0.45449546602004465241771763312107545D+00 px(19)= 0.55982869948207391699702170763669914D+00 px(20)= 0.68880504649787296744511192196333508D+00 px(21)= 0.84669796033901533360995646038438838D+00 px(22)= 0.10399324356558473561934598413040205D+01 px(23)= 0.12763377882779834661586906782407420D+01 px(24)= 0.15654589805265212137286807835074586D+01 px(25)= 0.19189432205583964070987477122905362D+01 px(26)= 0.23510260307961591423359389441199440D+01 px(27)= 0.28791534439182687258499291870153821D+01 px(28)= 0.35247986674670581588018777649051460D+01 px(29)= 0.43145708343894232186639323097990119D+01 px(30)= 0.52817877652195029549414854087069499D+01 px(31)= 0.64688326916686594614365796118970700D+01 px(32)= 0.79309297085796581254349823893132444D+01 px(33)= 0.97427028243618144296296506331896705D+01 px(34)= 0.12010788145502681400420281251059076D+02 px(35)= 0.14901634128904268951043131468444574D+02 px(36)= 0.18716850108988162034804184337830585D+02 px(37)= 0.24192677368936148334878341907713337D+02 pw( 1)= 0.99125336551824862194889482679760082D-03 pw( 2)= 0.23294764153889055024996601218914981D-02 pw( 3)= 0.37240772547834537676742266421935443D-02 pw( 4)= 0.52091149342528848273366607113774535D-02 pw( 5)= 0.68270221227859789716885624541247654D-02 pw( 6)= 0.86302549871569688435939302492406456D-02 pw( 7)= 0.10684907929606001826647765915296935D-01 pw( 8)= 0.13074823650284587459124044679067858D-01 pw( 9)= 0.15905815137012769943635728692865399D-01 pw(10)= 0.19309592949421631021202995586098476D-01 pw(11)= 0.23447231955796843102356124526512731D-01 pw(12)= 0.28512602643555882480364043596258204D-01 pw(13)= 0.34736803269082359319855891282489532D-01 pw(14)= 0.42394778196431500823106022890118590D-01 pw(15)= 0.51814900990726921245206073768999637D-01 pw(16)= 0.63391754887352977638748380428399567D-01 pw(17)= 0.77602103176771937423249866012581660D-01 pw(18)= 0.95024188094564273453247510650970162D-01 pw(19)= 0.11636084820208068310423973571076075D+00 pw(20)= 0.14246733764500807361275561785541076D+00 pw(21)= 0.17438513757282787980358846897741684D+00 pw(22)= 0.21338354906834882772151573726954513D+00 pw(23)= 0.26101159566291693588807442987832548D+00 pw(24)= 0.31916397294414160306456288368801219D+00 pw(25)= 0.39016685675452558044568607656388734D+00 pw(26)= 0.47689304458379631259135969323199221D+00 pw(27)= 0.58292255373275454371013059783773154D+00 pw(28)= 0.71277724055369180393369777699867214D+00 pw(29)= 0.87228215826925362283182363826585130D+00 pw(30)= 0.10691555317433509592820312414251932D+01 pw(31)= 0.13140356602358313756291999585335256D+01 pw(32)= 0.16224029261605229346735838359067505D+01 pw(33)= 0.20185076394260072518838683149008566D+01 pw(34)= 0.25443795429863924820797324346795088D+01 pw(35)= 0.32842160798477830990525297742207531D+01 pw(36)= 0.44504422639266402367212097908451198D+01 pw(37)= 0.68950534584189288110300715731079937D+01 endif if(kn == 38) then px( 1)= 0.37544882641214739544404487691314902D-03 px( 2)= 0.19871183957226785505693683210337852D-02 px( 3)= 0.49235906141676391015802154321946533D-02 px( 4)= 0.92514737512580193448510992395727495D-02 px( 5)= 0.15072210889929832914852564552062275D-01 px( 6)= 0.22529747565558688599709359818783270D-01 px( 7)= 0.31820706479818463453808764992549706D-01 px( 8)= 0.43207917804566229579979815937989733D-01 px( 9)= 0.57037614703055219788340245932475170D-01 px(10)= 0.73760278305643433875885418326364923D-01 px(11)= 0.93954814072806105125535625384970094D-01 px(12)= 0.11835572279751275812340426098616966D+00 px(13)= 0.14788342387597970850254556771271985D+00 px(14)= 0.18367881184867197784381084444678116D+00 px(15)= 0.22714406717510235393336995794234796D+00 px(16)= 0.27999230770730436478836636945630613D+00 px(17)= 0.34430881911279975709736095638802572D+00 px(18)= 0.42262660561797928237112864643574725D+00 px(19)= 0.51801914793576724661446993655612171D+00 px(20)= 0.63421369082081852676499438226656058D+00 px(21)= 0.77572913890901541203968257694714068D+00 px(22)= 0.94804373045176433040869132064288662D+00 px(23)= 0.11577991608735723735204737419458983D+01 px(24)= 0.14130499332620481162978195094240590D+01 px(25)= 0.17235697910838497297077019443263907D+01 px(26)= 0.21012318099421305470189826928381899D+01 px(27)= 0.25604863031155004117350909468147106D+01 px(28)= 0.31189733700354116534218512680792939D+01 px(29)= 0.37983289491193925871766329237375059D+01 px(30)= 0.46252830528399268638347963582117115D+01 px(31)= 0.56332239825265713634766419255858690D+01 px(32)= 0.68645515916046830561016745830456758D+01 px(33)= 0.83744595975704688906750898197385297D+01 px(34)= 0.10237521325244942798063968606118549D+02 px(35)= 0.12560368707162995423911721031640974D+02 px(36)= 0.15509653816608570103011114649053437D+02 px(37)= 0.19387848243793684608247770401886161D+02 px(38)= 0.24934561281635323945874914765928781D+02 pw( 1)= 0.96453265301318427548094362468201990D-03 pw( 2)= 0.22655173902979609807058505788853476D-02 pw( 3)= 0.36184028900176044156504296271444603D-02 pw( 4)= 0.50541489537150279336470105887486457D-02 pw( 5)= 0.66111480676528721493086153967962652D-02 pw( 6)= 0.83364709970141383682744167961798317D-02 pw( 7)= 0.10288965239682486008404941690219778D-01 pw( 8)= 0.12542814650103402794331337460320134D-01 pw( 9)= 0.15191255363614986206935175799741358D-01 pw(10)= 0.18350103409130288787013350611437802D-01 pw(11)= 0.22160882105318682870151221782836377D-01 pw(12)= 0.26793767627663720473790893510507021D-01 pw(13)= 0.32451109787899399883524910095936794D-01 pw(14)= 0.39372541954009629417292538828294592D-01 pw(15)= 0.47842474290684012119499234323721647D-01 pw(16)= 0.58200301955035707564120883548436910D-01 pw(17)= 0.70853350044334604149559560301899009D-01 pw(18)= 0.86292591208817884216614254072269241D-01 pw(19)= 0.10511141477535783724613732416344133D+00 pw(20)= 0.12802804286358628862797652201096219D+00 pw(21)= 0.15591251149396720172437659323068423D+00 pw(22)= 0.18981949259837187914390190669151597D+00 pw(23)= 0.23102871661757404151219056182072738D+00 pw(24)= 0.28109550616216987958688311291596089D+00 pw(25)= 0.34191517456611856887400710976438959D+00 pw(26)= 0.41580717321823436217712748531850542D+00 pw(27)= 0.50562861773538920954280122211069833D+00 pw(28)= 0.61493358954575527626904288123143367D+00 pw(29)= 0.74820721198453838888752387245859917D+00 pw(30)= 0.91122787666637256187790465660240598D+00 pw(31)= 0.11116604876702928314541969577850448D+01 pw(32)= 0.13600906035248579424433723117814169D+01 pw(33)= 0.16719605033700192144793651594580592D+01 pw(34)= 0.20715242290059813187830495943964160D+01 pw(35)= 0.26009149126553161918961209793496358D+01 pw(36)= 0.33446822473746498943306001989892373D+01 pw(37)= 0.45163779904182883931050846768355054D+01 pw(38)= 0.69731288252045659086112524629580346D+01 endif if(kn == 39) then px( 1)= 0.36561668715257863266695867839020084D-03 px( 2)= 0.19346233268023844607752680140092771D-02 px( 3)= 0.47914454654721250429608171020940566D-02 px( 4)= 0.89973768150331118636464557997751850D-02 px( 5)= 0.14645426459456932116061991386768235D-01 px( 6)= 0.21867035291160181873696376563265340D-01 px( 7)= 0.30840905275941465760959181463130484D-01 px( 8)= 0.41804727278858172089611260923812570D-01 px( 9)= 0.55070109596011254633584203260158210D-01 px(10)= 0.71040748192925559559810356000599258D-01 px(11)= 0.90233607305000360208735980487986444D-01 px(12)= 0.11330278644013276387294932973826412D+00 px(13)= 0.14106605202734226946949558771740988D+00 px(14)= 0.17453471922456742887333856505611605D+00 px(15)= 0.21494840120203884103453089817606487D+00 px(16)= 0.26381673974086082406623827494703215D+00 px(17)= 0.32297045833724193805138734154727157D+00 px(18)= 0.39462409178162717260419023658129017D+00 px(19)= 0.48145279757007806226628785793904093D+00 px(20)= 0.58668591241992432419881469135301121D+00 px(21)= 0.71422043441619441875490470925759117D+00 px(22)= 0.86875839397007365611188934469437619D+00 px(23)= 0.10559731561016268223241013124184012D+01 px(24)= 0.12827111749931695832113875967148563D+01 px(25)= 0.15572378120557119987867239447717751D+01 px(26)= 0.18895389181496921659373840308737441D+01 px(27)= 0.22916946565666188923157402572614733D+01 px(28)= 0.27783497396142931899333530655336223D+01 px(29)= 0.33673171344416414054075236409384439D+01 px(30)= 0.40803746579421435360342926127423516D+01 px(31)= 0.49443541982197303363350679681860647D+01 px(32)= 0.59926991656565097356612507658187921D+01 px(33)= 0.72678162022521051390335450639073869D+01 px(34)= 0.88248661080276432761936204880867089D+01 px(35)= 0.10738377470289614240120984197486960D+02 px(36)= 0.13114992524642316318648160324994074D+02 px(37)= 0.16121587864037157860973324745148775D+02 px(38)= 0.20061517632007615495343028194490514D+02 px(39)= 0.25677751590102375173572742100364982D+02 pw( 1)= 0.93922220165197278758235278705125378D-03 pw( 2)= 0.22050238560788499833482429614154492D-02 pw( 3)= 0.35187216063020038804486790499409390D-02 pw( 4)= 0.49085365506617880092326144941967522D-02 pw( 5)= 0.64093236535073721253961413565734053D-02 pw( 6)= 0.80634829478885867255854065621590218D-02 pw( 7)= 0.99236234747694546900134742610818704D-02 pw( 8)= 0.12055651790884970603397688654161516D-01 pw( 9)= 0.14542041549622581450180752510105879D-01 pw(10)= 0.17484998327571243644029476510788471D-01 pw(11)= 0.21009295862219636601744654763649681D-01 pw(12)= 0.25264862509860073296774992740630911D-01 pw(13)= 0.30429647240913452161840939756263150D-01 pw(14)= 0.36713599504420717007290949145895236D-01 pw(15)= 0.44364526109307181291869691370038599D-01 pw(16)= 0.53676231693459070390920038412533532D-01 pw(17)= 0.64999020675906355562370375168522980D-01 pw(18)= 0.78752553989958863994856994484156486D-01 pw(19)= 0.95441198327713183692637121288756175D-01 pw(20)= 0.11567225339206538896170499893449828D+00 pw(21)= 0.14017770592600709076251201422928256D+00 pw(22)= 0.16984043156916862434884153031547730D+00 pw(23)= 0.20572609864904223612685592628540649D+00 pw(24)= 0.24912251113833289072621517399741476D+00 pw(25)= 0.30158889670929686638710684005186011D+00 pw(26)= 0.36501892348491283180440889799004221D+00 pw(27)= 0.44172341189659552954879007161166844D+00 pw(28)= 0.53454253015480261760607954897116394D+00 pw(29)= 0.64700413373280623862585575306735597D+00 pw(30)= 0.78355765539183802574608463599148275D+00 pw(31)= 0.94993752822514424638014213628449162D+00 pw(32)= 0.11537599191614455897031555123375337D+01 pw(33)= 0.14055641164435818777056131176331966D+01 pw(34)= 0.17207623206557334615184702866032957D+01 pw(35)= 0.21236210670677286367475649834301224D+01 pw(36)= 0.26563848390712257212223490954097065D+01 pw(37)= 0.34039597582687380169009802962894561D+01 pw(38)= 0.45810165654673262153491823163228067D+01 pw(39)= 0.70497477205153040846297597338553262D+01 endif if(kn == 40) then px( 1)= 0.35628858567646346686837324510549370D-03 px( 2)= 0.18848536486770311807591243848705546D-02 px( 3)= 0.46663181280317856746168443158323968D-02 px( 4)= 0.87572190745324032833162010260613025D-02 px( 5)= 0.14243053462025729117427416370397854D-01 px( 6)= 0.21244187714177671012923575144774521D-01 px( 7)= 0.29923549070178329860704059006245261D-01 px( 8)= 0.40496827285887221934804797848083118D-01 px( 9)= 0.53245474481585595162008164942410512D-01 px(10)= 0.68532582430157398594384714629729053D-01 px(11)= 0.86821479567961854490494392488927025D-01 px(12)= 0.10869675959524067911380119096839804D+00 px(13)= 0.13488761722649275069059959653024014D+00 px(14)= 0.16629388885455273807852247897310019D+00 px(15)= 0.20401590432120076472183920609098846D+00 px(16)= 0.24938984749465339706889280753165521D+00 px(17)= 0.30403061355446670063478194165459695D+00 px(18)= 0.36988419909316149270323787724602738D+00 px(19)= 0.44929166750312582192671647579960907D+00 px(20)= 0.54506686870623140996608099899850594D+00 px(21)= 0.66059043398617261201896956069992349D+00 px(22)= 0.79992312516554243682533149390065526D+00 px(23)= 0.96794240207734869040410161024196399D+00 px(24)= 0.11705071340447720718704866053067197D+01 px(25)= 0.14146568411163837104501550620112388D+01 px(26)= 0.17088539364613371655586392377700409D+01 px(27)= 0.20632805527205428543659205472373927D+01 px(28)= 0.24902063739619416723013658330633921D+01 px(29)= 0.30044517126674338175114949672570867D+01 px(30)= 0.36239831566943951780098581431720407D+01 px(31)= 0.43707017882279510268089904263627705D+01 px(32)= 0.52715247584257797079839546521646347D+01 px(33)= 0.63599375545114314246728093354610643D+01 px(34)= 0.76783457965158492083638000098773087D+01 px(35)= 0.92818762327705176821137326934557272D+01 px(36)= 0.11245019162985129683252871377987811D+02 px(37)= 0.13674441002824139783929760948169562D+02 px(38)= 0.16737262031081031207287624813172862D+02 px(39)= 0.20737736626704553460329127303821744D+02 px(40)= 0.26422185009410264431343933932848600D+02 pw( 1)= 0.91521311273862401110414707754929676D-03 pw( 2)= 0.21477191521928219197974773759587103D-02 pw( 3)= 0.34245277733745781136392870149979323D-02 pw( 4)= 0.47714307428687057651870425259278087D-02 pw( 5)= 0.62201720373839252470536835470530964D-02 pw( 6)= 0.78090816762799270025355432702422127D-02 pw( 7)= 0.95853728776285881753692296587104674D-02 pw( 8)= 0.11607827206228475028893871423142139D-01 pw( 9)= 0.13949671718334027814092300225470600D-01 pw(10)= 0.16701414648594482319533882783791014D-01 pw(11)= 0.19973423842092704666661066907283955D-01 pw(12)= 0.23898237345016617036372142753573396D-01 pw(13)= 0.28632957303620028137537791558953675D-01 pw(14)= 0.34362389756581172586707762233025920D-01 pw(15)= 0.41303629060426009015015262453667296D-01 pw(16)= 0.49712538117407657728121783442595623D-01 pw(17)= 0.59892265779927519547458491064456622D-01 pw(18)= 0.72203793116717427042782050909270304D-01 pw(19)= 0.87078559354632307141427375007562753D-01 pw(20)= 0.10503340154082661838457995134010675D+00 pw(21)= 0.12668825810872029062869005987170137D+00 pw(22)= 0.15278730399841792433216511718627756D+00 pw(23)= 0.18422442714170367120354764302353497D+00 pw(24)= 0.22207427969059917966672557751489214D+00 pw(25)= 0.26763062752730913486480650477422812D+00 pw(26)= 0.32245451049240744596849032983153986D+00 pw(27)= 0.38843603675318055142995014015287773D+00 pw(28)= 0.46787586661529213993652263387714350D+00 pw(29)= 0.56359633220992492533897924842606201D+00 pw(30)= 0.67909910572915995345517074647986275D+00 pw(31)= 0.81879920277693732798543935642566763D+00 pw(32)= 0.98838986255598396167621024931216632D+00 pw(33)= 0.11954429228293928218210248618287692D+01 pw(34)= 0.14504574076282353803601676013439121D+01 pw(35)= 0.17688226967485673903033088821262440D+01 pw(36)= 0.21748255570140773474399755838047824D+01 pw(37)= 0.27108286283847583355764140776741630D+01 pw(38)= 0.34620975677969687591016085409314313D+01 pw(39)= 0.46444137521824838114376662229079725D+01 pw(40)= 0.71249713212825268738104553603659849D+01 endif if(kn == 41) then px( 1)= 0.34742673101001169298125786189192247D-03 px( 2)= 0.18376016626066348589572611512977315D-02 px( 3)= 0.45476582212664459469467031011454626D-02 px( 4)= 0.85298627941631364768947297314276555D-02 px( 5)= 0.13862998302969016172574004035541326D-01 px( 6)= 0.20657586094570613395846290407493021D-01 px( 7)= 0.29062610848297752288163047809306784D-01 px( 8)= 0.39274425358723378021088136325757383D-01 px( 9)= 0.51548104852787877566528890250659503D-01 px(10)= 0.66211354354233299700140534259286291D-01 px(11)= 0.83680871232624778086967339679729237D-01 px(12)= 0.10448092042565902676173295142297193D+00 px(13)= 0.12926394759018944327153762885108248D+00 px(14)= 0.15883342588000497563552833153551216D+00 px(15)= 0.19416971506631978910646170849840836D+00 px(16)= 0.23646026989593002896655227863024343D+00 px(17)= 0.28713586785719640965554266593644607D+00 px(18)= 0.34791462052391896376462581083932962D+00 px(19)= 0.42085552853141849349998238918417102D+00 px(20)= 0.50842339932407666570140739641291868D+00 px(21)= 0.61356716058210435249023757196485689D+00 px(22)= 0.73981399451706291428067431492187345D+00 px(23)= 0.89138229125166542251073985530751701D+00 px(24)= 0.10733171950376849976883148880289368D+01 px(25)= 0.12916535619608503598632452641060769D+01 px(26)= 0.15536125962495445292827177181517718D+01 px(27)= 0.18678405221272713224762723085314113D+01 px(28)= 0.22447007897223064544921318025044505D+01 px(29)= 0.26966362208010185020303083586792707D+01 px(30)= 0.32386254398637317225899745563640301D+01 px(31)= 0.38887712166747737454815122744695001D+01 px(32)= 0.46690813167550880509031095796259491D+01 px(33)= 0.56065436673995350526181894949125319D+01 px(34)= 0.67346748355004755553478375342343373D+01 px(35)= 0.80958733206377174584850755308484861D+01 px(36)= 0.97452318197102039374768068435419398D+01 px(37)= 0.11757209117436549173752389088784801D+02 px(38)= 0.14238509041698890616269777375250039D+02 px(39)= 0.17356513104267573046562740943972043D+02 px(40)= 0.21416391258741087275776630427364534D+02 px(41)= 0.27167802059826190961056594217938860D+02 pw( 1)= 0.89240744144922233411809208993761819D-03 pw( 2)= 0.20933555605342582529457970383304286D-02 pw( 3)= 0.33353720205083480430061442115773668D-02 pw( 4)= 0.46420859644861606778799308270413399D-02 pw( 5)= 0.60424942046045364422720752662654441D-02 pw( 6)= 0.75713643924191847990582966217707736D-02 pw( 7)= 0.92712216138022670728066109402065568D-02 pw( 8)= 0.11194687905391631640874958915231129D-01 pw( 9)= 0.13407015211365284658909716719520612D-01 pw(10)= 0.15988623214362774067334406180515621D-01 pw(11)= 0.19037444847571012625771486857897508D-01 pw(12)= 0.22671015569010270758765332286863717D-01 pw(13)= 0.27028523256092179219838374149240132D-01 pw(14)= 0.32273327230549150524506142920429224D-01 pw(15)= 0.38596560710149393493004578367090095D-01 pw(16)= 0.46222282500302385970118307137327059D-01 pw(17)= 0.55414377032731402665476377100171599D-01 pw(18)= 0.66485217878875067216476264141658569D-01 pw(19)= 0.79806099857296581997108727302834078D-01 pw(20)= 0.95819567831341990475832520086841170D-01 pw(21)= 0.11505394471321825395206987370902480D+00 pw(22)= 0.13814054039338535506658629671808687D+00 pw(23)= 0.16583420916823077593541262981490681D+00 pw(24)= 0.19903814998014368860888042911909173D+00 pw(25)= 0.23883416675372027779180574899396133D+00 pw(26)= 0.28652010702264135124796999487042423D+00 pw(27)= 0.34365700663826115610743525613053815D+00 pw(28)= 0.41212981100557300459399743393003457D+00 pw(29)= 0.49422782047790986141383860345034700D+00 pw(30)= 0.59275496121528084438932784828140258D+00 pw(31)= 0.71118703347840582157967515903715531D+00 pw(32)= 0.85390607737164494406520343373727721D+00 pw(33)= 0.10265669138579149759586965414767668D+01 pw(34)= 0.12367012590999922651850699786000809D+01 pw(35)= 0.14947734294405908884100490275594732D+01 pw(36)= 0.18161565391675246807943861856738552D+01 pw(37)= 0.22251644165626364386518263812767700D+01 pw(38)= 0.27642836611922099334373971118073338D+01 pw(39)= 0.35191416662378097344643779658011469D+01 pw(40)= 0.47066216438742057965343731115092608D+01 pw(41)= 0.71988567667853812451766331822159390D+01 endif if(kn == 42) then px( 1)= 0.33899702213207280303556565703741990D-03 px( 2)= 0.17926803514586918122543179233298713D-02 px( 3)= 0.44349720472477033588788261295928634D-02 px( 4)= 0.83142928381370954944600712429031326D-02 px( 5)= 0.13503405398912139202218387144909328D-01 px( 6)= 0.20104047687222803992574530787065418D-01 px( 7)= 0.28252833643724993821423023769509983D-01 px( 8)= 0.38129051839561461833536104861505433D-01 px( 9)= 0.49964611823304399745794720191846551D-01 px(10)= 0.64056255466771758626847757441909748D-01 px(11)= 0.80779982442382913230902383270370264D-01 px(12)= 0.10060749467110151157610640414769097D+00 px(13)= 0.12412446888143911749100232205634547D+00 px(14)= 0.15205071694865663047292718989423185D+00 px(15)= 0.18526275842687218439176583557408384D+00 px(16)= 0.22481983515906206676758114216568014D+00 px(17)= 0.27199475262711723613680204884879081D+00 px(18)= 0.32831107191481630404052581830045252D+00 px(19)= 0.39558818386929789909718409480658300D+00 px(20)= 0.47599581233231530250697095670252798D+00 px(21)= 0.57211961616026616366050109797592391D+00 px(22)= 0.68703982771101430011400322499023268D+00 px(23)= 0.82442528240215569955771735381318182D+00 px(24)= 0.98864576667159865631116805089235696D+00 px(25)= 0.11849063745873302190560203655789150D+01 px(26)= 0.14194085949505718343903162487063753D+01 px(27)= 0.16995442942632463982698312503343140D+01 px(28)= 0.20341308620656637127889186046327503D+01 px(29)= 0.24336989628881715953740329050451161D+01 px(30)= 0.29108493179186889815360617341447733D+01 px(31)= 0.34807029996457758665062194913386789D+01 px(32)= 0.41614831892896507985708808145127823D+01 px(33)= 0.49752895914290239340663575251573810D+01 px(34)= 0.59491683086745559122027634515663744D+01 px(35)= 0.71166577579837023101788394059159047D+01 px(36)= 0.85201446660709564225208283238116453D+01 px(37)= 0.10214688587324610607847909840137625D+02 px(38)= 0.12274723743508615874901666750507663D+02 px(39)= 0.14807003938009410302904866873102566D+02 px(40)= 0.17979187958243548948159702687043315D+02 px(41)= 0.22097374571880291313408725390611447D+02 px(42)= 0.27914546740390271130933515005738687D+02 pw( 1)= 0.87071685062486345289172157206777171D-03 pw( 2)= 0.20417105878963868357298871515770460D-02 pw( 3)= 0.32508535230574150323908782582998050D-02 pw( 4)= 0.45198431212516341141392418533095799D-02 pw( 5)= 0.58752408889593859079959250826252330D-02 pw( 6)= 0.73486832934924937540882060804195150D-02 pw( 7)= 0.89786045784956752332612520710862566D-02 pw( 8)= 0.10812279756759579335639253148771645D-01 pw( 9)= 0.12908056239717444457676015564846892D-01 pw(10)= 0.15337623022218768136530241218842739D-01 pw(11)= 0.18188143417513304840817866168341234D-01 pw(12)= 0.21564159053085002516938026776853287D-01 pw(13)= 0.25589384327944258948303670138994570D-01 pw(14)= 0.30408768217117848936156421895538494D-01 pw(15)= 0.36191344708155839281431088511826248D-01 pw(16)= 0.43134326776658801296020544503200249D-01 pw(17)= 0.51468687405796338041097105695766697D-01 pw(18)= 0.61466278505771427877600196882159870D-01 pw(19)= 0.73448477231342626126309188685807545D-01 pw(20)= 0.87796417742468560052699023987407758D-01 pw(21)= 0.10496300171125714320281462758628502D+00 pw(22)= 0.12548703017795381911118827176515123D+00 pw(23)= 0.15000994875313221416387070158771740D+00 pw(24)= 0.17929586510892162331076812701124762D+00 pw(25)= 0.21425571841544983392913772225490756D+00 pw(26)= 0.25597680754299265400920520155620068D+00 pw(27)= 0.30575939808892163354965075699382712D+00 pw(28)= 0.36516295819168300959340602426394554D+00 pw(29)= 0.43606594548816172375527529406447798D+00 pw(30)= 0.52074538635856855968547701789163874D+00 pw(31)= 0.62198649880275266624161896479324475D+00 pw(32)= 0.74323973657036909817079545894769618D+00 pw(33)= 0.88885572273739267168333040860537136D+00 pw(34)= 0.10644536078580082753759483481056876D+01 pw(35)= 0.12775289785980491630656102334631630D+01 pw(36)= 0.15385165702010908217004674883905600D+01 pw(37)= 0.18627791456676687262611182457669180D+01 pw(38)= 0.22746636192228746631618234661193503D+01 pw(39)= 0.28167854835143406837432208820997977D+01 pw(40)= 0.35751353025579259567249078677450433D+01 pw(41)= 0.47676889791677097956471776553934610D+01 pw(42)= 0.72714575121908501417344894592801099D+01 endif if(kn == 43) then px( 1)= 0.33096860786757750154898847120917057D-03 px( 2)= 0.17499208566123461094898550046151874D-02 px( 3)= 0.43278154096847331355188904178071447D-02 px( 4)= 0.81096003646317825364067625754120221D-02 px( 5)= 0.13162623744349233672062735003036974D-01 px( 6)= 0.19580760979979784765554480104376286D-01 px( 7)= 0.27489609951663532195103068673087354D-01 px( 8)= 0.37053342869799653592283933396820960D-01 px( 9)= 0.48483444452707627033448163720522761D-01 px(10)= 0.62049459953072389488156028383179189D-01 px(11)= 0.78091737934971368286739663026054961D-01 px(12)= 0.97036017163386886705197231591959380D-01 px(13)= 0.11940967168918372175774848212559756D+00 px(14)= 0.14585958712300992040134315459436264D+00 px(15)= 0.17717200022543900754299287107723618D+00 px(16)= 0.21429507577429224752942159606670995D+00 px(17)= 0.25836535107930525415060613221934697D+00 px(18)= 0.31073935543877479582966549813156744D+00 px(19)= 0.37303174367650550564362643090028699D+00 px(20)= 0.44716127946900452807387231860775343D+00 px(21)= 0.53540606537110705599704958284246183D+00 px(22)= 0.64046959170961720285075028881968045D+00 px(23)= 0.76555947611245457114222548768598476D+00 px(24)= 0.91448119032995475750346963701721081D+00 px(25)= 0.10917496366295753151128433644125688D+01 px(26)= 0.13027221869155879323859021531153006D+01 px(27)= 0.15537578204695570075088633454278321D+01 px(28)= 0.18524084405877676482171967152697008D+01 px(29)= 0.22076505684206197863173711190960219D+01 px(30)= 0.26301688303884504911030778880813732D+01 px(31)= 0.31327077074207879423269172652003364D+01 px(32)= 0.37305161917200709143270025763858640D+01 px(33)= 0.44419236396092482776254163193454757D+01 px(34)= 0.52891086092067566005114585507151512D+01 px(35)= 0.62991644484541209348967251319712091D+01 px(36)= 0.75056437278338836321053009023954332D+01 px(37)= 0.89509179672327616775374703555124487D+01 px(38)= 0.10690015208487653327362214867738207D+02 px(39)= 0.12797352129263264861734948864857745D+02 px(40)= 0.15379744394428552764554128123427935D+02 px(41)= 0.18605142714959248273487455172506479D+02 px(42)= 0.22780586028957730000926904102977113D+02 px(43)= 0.28662366237232832381924388811320297D+02 pw( 1)= 0.85006145870848429334757469982573891D-03 pw( 2)= 0.19925838109657703878469708707415329D-02 pw( 3)= 0.31706135365278565227115398483457554D-02 pw( 4)= 0.44041172343279662518790702958553625D-02 pw( 5)= 0.57174896648731729427179253475841935D-02 pw( 6)= 0.71396041280184287136596813041547263D-02 pw( 7)= 0.87053105293648014281590926123488040D-02 pw( 8)= 0.10457223593582426133616067442291247D-01 pw( 9)= 0.12447691003362071183889633075575652D-01 pw(10)= 0.14740821116468595319728157346456377D-01 pw(11)= 0.17414420402114891406970230872875573D-01 pw(12)= 0.20561736545282396913149978083028889D-01 pw(13)= 0.24293057998247351709738591334952020D-01 pw(14)= 0.28737438822145949516145087089517893D-01 pw(15)= 0.34044977279791239841839057487094614D-01 pw(16)= 0.40390072912737209513481740353650117D-01 pw(17)= 0.47975933504865389303614731289416436D-01 pw(18)= 0.57040421240269648291641111667509080D-01 pw(19)= 0.67863232374253637764436196090399013D-01 pw(20)= 0.80774426563059878523617995686503505D-01 pw(21)= 0.96164420051293883535914595526514204D-01 pw(22)= 0.11449568019439733156432157598398321D+00 pw(23)= 0.13631648279559252800439663886965342D+00 pw(24)= 0.16227722290947194423527738296713650D+00 pw(25)= 0.19314992693280818601029240961091576D+00 pw(26)= 0.22985183401280394837726875217480564D+00 pw(27)= 0.27347424857196858115127321375763169D+00 pw(28)= 0.32531839177175415639431272795218179D+00 pw(29)= 0.38694082912221267186717847996208730D+00 pw(30)= 0.46021245154573169215949688893911839D+00 pw(31)= 0.54739734403912358955407316606691874D+00 pw(32)= 0.65126193729202891760603881973382504D+00 pw(33)= 0.77523203175189474974013051456241330D+00 pw(34)= 0.92362846689464044743151918155531626D+00 pw(35)= 0.11020374135362457925484267398369432D+01 pw(36)= 0.13179220978816197700516342241847467D+01 pw(37)= 0.15816923933252917714931130477654841D+01 pw(38)= 0.19087060424955494066311220499293247D+01 pw(39)= 0.23233483559535813743753279936284135D+01 pw(40)= 0.28683678978287494020672145638838434D+01 pw(41)= 0.36301191889236335565768841054222539D+01 pw(42)= 0.48276614242022139042477288493084378D+01 pw(43)= 0.73428236438762783138460481364952627D+01 endif if(kn == 44) then px( 1)= 0.32331350836957546603744084419849788D-03 px( 2)= 0.17091703169716826666769331280363544D-02 px( 3)= 0.42257875064315455206561743770986376D-02 px( 4)= 0.79149690832372160827916911872302865D-02 px( 5)= 0.12839179023186853233140061142661062D-01 px( 6)= 0.19085232241568949577899855509474977D-01 px( 7)= 0.26768883186791699077493305776558926D-01 px( 8)= 0.36040864557027892650839059295103373D-01 px( 9)= 0.47094585778667144264845412823636449D-01 px(10)= 0.60175615761544264401796703227341314D-01 px(11)= 0.75592961225388113581704029754538741D-01 px(12)= 0.93732029387412788080736336661325883D-01 px(13)= 0.11506910593622805003749038841255850D+00 px(14)= 0.14018727035639085866142640394142696D+00 px(15)= 0.16979393946354437271616691990993614D+00 px(16)= 0.20474060430292067802523043906109989D+00 px(17)= 0.24604566740448100845633933054720796D+00 px(18)= 0.29492149096685690036119497895105667D+00 px(19)= 0.35280682708785925696562700896642017D+00 px(20)= 0.42140579664772257270434756016372204D+00 px(21)= 0.50273460611520704557595850856713180D+00 px(22)= 0.59917729885865279633574477547906320D+00 px(23)= 0.71355204803416102949757204396579206D+00 px(24)= 0.84918981260514039761248477195520438D+00 px(25)= 0.10100276016887074982125673033831345D+01 px(26)= 0.12007191488994777606413935958511916D+01 px(27)= 0.14267665395522811775994265815554724D+01 px(28)= 0.16946773518359189852395063278947950D+01 px(29)= 0.20121533231038550963171865171844820D+01 px(30)= 0.23883186915697571717337880438736199D+01 px(31)= 0.28339996248002878664983052972434529D+01 px(32)= 0.33620712713198530053650295556681017D+01 px(33)= 0.39878972622760453246577762221089257D+01 px(34)= 0.47299002992789324698627794306541718D+01 px(35)= 0.56103262027415485179449762966436919D+01 px(36)= 0.66563061139504917392538125507749794D+01 px(37)= 0.79014003881557845126238132373008625D+01 px(38)= 0.93879629282953731177093056973506411D+01 px(39)= 0.11170992458953013913700288894894255D+02 px(40)= 0.13324895111520577881664368628734089D+02 px(41)= 0.15956559624176004069472090284905753D+02 px(42)= 0.19234241988629565032886618545011883D+02 px(43)= 0.23465930980103016989495364982244146D+02 px(44)= 0.29411210662212999597346209126697707D+02 pw( 1)= 0.83036884987403513181911166534208663D-03 pw( 2)= 0.19457941864115460112729277032771097D-02 pw( 3)= 0.30943299472937825975912487677647078D-02 pw( 4)= 0.42943871620956718877444401513682917D-02 pw( 5)= 0.55684261348013693314562032089920088D-02 pw( 6)= 0.69428725530123470368722128932621244D-02 pw( 7)= 0.84494234604398957532432243635753483D-02 pw( 8)= 0.10126616172976027067397699017267216D-01 pw( 9)= 0.12021566160747622141057949671782224D-01 pw(10)= 0.14191778414242213809164508501045497D-01 pw(11)= 0.16706905485358088359523445571590018D-01 pw(12)= 0.19650346938023694904494456157357191D-01 pw(13)= 0.23120695042785977245044097938079732D-01 pw(14)= 0.27233209875082837015975056631389154D-01 pw(15)= 0.32121665600246232435212867479076854D-01 pw(16)= 0.37940949845194110884289250317530407D-01 pw(17)= 0.44870698984096406199701289089460328D-01 pw(18)= 0.53120093303752446444612781898982047D-01 pw(19)= 0.62933823516449817737731500047201570D-01 pw(20)= 0.74599224373678150636698930396457382D-01 pw(21)= 0.88454634536330462816566048592135618D-01 pw(22)= 0.10489914083790778708121373941299966D+00 pw(23)= 0.12440396953470249784020277878699461D+00 pw(24)= 0.14752589155074737609776847913675882D+00 pw(25)= 0.17492312579420798336376479913219788D+00 pw(26)= 0.20737437787760038519638439806427540D+00 pw(27)= 0.24580187433567244121381237836878940D+00 pw(28)= 0.29129959389673368311222620480570831D+00 pw(29)= 0.34516843605203008284533614069195425D+00 pw(30)= 0.40896093500380134048288051036096437D+00 pw(31)= 0.48453955284019804235911876681118743D+00 pw(32)= 0.57415497731524515579134334664918167D+00 pw(33)= 0.68055495684587130214889340452349758D+00 pw(34)= 0.80714146055673592921708826105860249D+00 pw(35)= 0.95820721891454345652447310233062356D+00 pw(36)= 0.11393080348437704220650007990276423D+01 pw(37)= 0.13578783180672521841897407574039451D+01 pw(38)= 0.16243074162684344243952826001273292D+01 pw(39)= 0.19539528530618256474917072512577991D+01 pw(40)= 0.23712430126501098428281754997758214D+01 pw(41)= 0.29190630527561174415810627420409994D+01 pw(42)= 0.36841316877299013922727992267156054D+01 pw(43)= 0.48865818259133309055220603437140743D+01 pw(44)= 0.74130021614058319715789731577046943D+01 endif if(kn == 45) then px( 1)= 0.31600628834973779292559127048190037D-03 px( 2)= 0.16702900106190273328935895866739893D-02 px( 3)= 0.41285257114804008864642830706317964D-02 px( 4)= 0.77296636135218507544800673352591724D-02 px( 5)= 0.12531750213154611452085965505028540D-01 px( 6)= 0.18615241131540077290889348326202186D-01 px( 7)= 0.26087066631843252886061485477515189D-01 px( 8)= 0.35085969566222178513934460224332887D-01 px( 9)= 0.45789306577033888813174278261897663D-01 px(10)= 0.58421434435784388362459047968056087D-01 px(11)= 0.73263711622882621260808485115770070D-01 px(12)= 0.90666037430716786669379135384670844D-01 px(13)= 0.11105978210403381887459852100321712D+00 px(14)= 0.13497200418547898709664745719407710D+00 px(15)= 0.16304104546216750230118904547804422D+00 px(16)= 0.19603390202336562386932779699909816D+00 px(17)= 0.23486608544820513725469302847128384D+00 px(18)= 0.28062490631545969684155812688765467D+00 px(19)= 0.33459720050887095268667406972580638D+00 px(20)= 0.39830252448023971951147973257838648D+00 px(21)= 0.47353284765622731594152923198004578D+00 px(22)= 0.56239982933240531713761978532829046D+00 px(23)= 0.66739091019498584233201402129369733D+00 px(24)= 0.79143567909811363215071199148744656D+00 px(25)= 0.93798429449898007763809445265874043D+00 px(26)= 0.11111001581385252565298438994097319D+01 px(27)= 0.13155695863345333806714751926528375D+01 px(28)= 0.15570319587074322621285835341493748D+01 px(29)= 0.18421348417902183390620002381054988D+01 px(30)= 0.21787200444979152172206336828110265D+01 px(31)= 0.25760487257631498506605264603704116D+01 px(32)= 0.30450769803228709332081128619189764D+01 px(33)= 0.35987985256158263799485414495379126D+01 px(34)= 0.42526795117768400994862312123212388D+01 px(35)= 0.50252244422171176606674140586086445D+01 px(36)= 0.59387361521365530542536690567593329D+01 px(37)= 0.70203754298618509877391417240792276D+01 px(38)= 0.83037051949719291418317245580593492D+01 px(39)= 0.98310601809174348734008913125923897D+01 px(40)= 0.11657412426662143324540788749464127D+02 px(41)= 0.13857164426266931434200566791289955D+02 px(42)= 0.16537288540540952756080764303901777D+02 px(43)= 0.19866358206258941542582357564294186D+02 px(44)= 0.24153320185396072162240284411839110D+02 px(45)= 0.30161032818176703094230836042654050D+02 pw( 1)= 0.81157322026241886094392714295783692D-03 pw( 2)= 0.19011777475163676304804330211208542D-02 pw( 3)= 0.30217126568442239903479316417011601D-02 pw( 4)= 0.41901870013204838998208477401165665D-02 pw( 5)= 0.54273283828323581210343431353844446D-02 pw( 6)= 0.67573866388465515363650925512746062D-02 pw( 7)= 0.82092751225427288897814574011554460D-02 pw( 8)= 0.98179504955536258107199257981433439D-02 pw( 9)= 0.11625949429528062575538287604998941D-01 pw(10)= 0.13685006654390859174410475886206370D-01 pw(11)= 0.16057648452306267238525538418198228D-01 pw(12)= 0.18818661412340581662760322741958838D-01 pw(13)= 0.22056412054981119160700553625749748D-01 pw(14)= 0.25874134633155885709619608590472202D-01 pw(15)= 0.30391451859719384524106580753360271D-01 pw(16)= 0.35746460932048448724214073937351505D-01 pw(17)= 0.42098664685115079575098628197326142D-01 pw(18)= 0.49632898864791727296990224145235518D-01 pw(19)= 0.58564289944594589064829987997677920D-01 pw(20)= 0.69144234514984419908558444457124034D-01 pw(21)= 0.81667423637721859042077146566843517D-01 pw(22)= 0.96480011247988074883978780802066204D-01 pw(23)= 0.11398911344507944971212279753122991D+00 pw(24)= 0.13467391267458107409324694436955753D+00 pw(25)= 0.15909873207292332703499649578337212D+00 pw(26)= 0.18792855598692739186974920544448162D+00 pw(27)= 0.22194762553095863671304473597844931D+00 pw(28)= 0.26208196494751982936477406183051153D+00 pw(29)= 0.30942704406840347450420829122426871D+00 pw(30)= 0.36528233311686115136869183803961988D+00 pw(31)= 0.43119539125683582249214467187083528D+00 pw(32)= 0.50901957973734783536801637831942790D+00 pw(33)= 0.60099191357850333533977421143095798D+00 pw(34)= 0.70984171451926250865508439176773176D+00 pw(35)= 0.83894803839540918949226578045417203D+00 pw(36)= 0.99257719538081268693583754948673040D+00 pw(37)= 0.11762571380368294152931731126534612D+01 pw(38)= 0.13973967807100820386062004887130792D+01 pw(39)= 0.16663689232723581345802345799199851D+01 pw(40)= 0.19985351917633034604206124546990186D+01 pw(41)= 0.24183711599931949498296065604711404D+01 pw(42)= 0.29689015304223315699189706042837967D+01 pw(43)= 0.37372089827137538865937716176457237D+01 pw(44)= 0.49444904398530770204722137069339350D+01 pw(45)= 0.74820372303276097896128738491191685D+01 endif if(kn == 46) then px( 1)= 0.30902377399120893788354424898855426D-03 px( 2)= 0.16331537506671398843215268321368443D-02 px( 3)= 0.40357010980175320995569579449408174D-02 px( 4)= 0.75530195763806797812195436379199476D-02 px( 5)= 0.12239149854724502952182976196758722D-01 px( 6)= 0.18168803621919060471207612598191755D-01 px( 7)= 0.25440976363694145320552734001486569D-01 px( 8)= 0.34183679422904259346408703316308100D-01 px( 9)= 0.44559964643964573543760075913259475D-01 px(10)= 0.56775358517699538859278511856645348D-01 px(11)= 0.71086748757462020933356688085151754D-01 px(12)= 0.87812673145710441814424785984121246D-01 px(13)= 0.10734488854150171164189046430233515D+00 px(14)= 0.13016110718036063404346759877348097D+00 px(15)= 0.15683892196176944176774935350653314D+00 px(16)= 0.18807118924767432734960867652772029D+00 px(17)= 0.22468341948583423108691031411123462D+00 px(18)= 0.26765394743983501400088905846999460D+00 px(19)= 0.31813776531045013135926232571664330D+00 px(20)= 0.37749492399880062738311332663588965D+00 px(21)= 0.44732440247018853385136813722855067D+00 px(22)= 0.52950437210775343555603255060398518D+00 px(23)= 0.62623987488687805361419457851831370D+00 px(24)= 0.74011910006308993968762196795007188D+00 px(25)= 0.87417968361959824522374584708126947D+00 px(26)= 0.10319867719667534605241559659266134D+01 px(27)= 0.12177250028776661981781648200867157D+01 px(28)= 0.14363070973204841479279696750353849D+01 px(29)= 0.16935024864806789035793857077605729D+01 px(30)= 0.19960904185444808460178685393801009D+01 px(31)= 0.23520434618090888941520463681053941D+01 px(32)= 0.27707495103418382337989450786653183D+01 px(33)= 0.32632837492864188626066742354315931D+01 px(34)= 0.38427473041855077266339137871017428D+01 px(35)= 0.45246978009253960226440639549407685D+01 px(36)= 0.53277111750428588477775437304742452D+01 px(37)= 0.62741382355089597665586817773799499D+01 px(38)= 0.73911624234084726194161817156844889D+01 px(39)= 0.87123449938120379656808053147144537D+01 px(40)= 0.10280000673796667050592943428615469D+02 px(41)= 0.12149077777983097408939533602647387D+02 px(42)= 0.14393981931423795298134131653931530D+02 px(43)= 0.17121779022116518315203538273624565D+02 px(44)= 0.20501370994989532793115106347627070D+02 px(45)= 0.24842669385551363138030331359754804D+02 px(46)= 0.30911787987864913738727989247192145D+02 pw( 1)= 0.79361463897360195929686273302248409D-03 pw( 2)= 0.18585856237700307630029880256700761D-02 pw( 3)= 0.29524996535416808392477309033103772D-02 pw( 4)= 0.40910988545579399083185141944050702D-02 pw( 5)= 0.52935540515794390997929859327326122D-02 pw( 6)= 0.65821742586378490181117941215141045D-02 pw( 7)= 0.79834063288880762331149927032946792D-02 pw( 8)= 0.95290513069482303557158918089126201D-02 pw( 9)= 0.11257625314697109024742951848074159D-01 pw(10)= 0.13215805246967286000173950239611213D-01 pw(11)= 0.15459871723048351392169871195100160D-01 pw(12)= 0.18057057593147761999943506400696980D-01 pw(13)= 0.21086760440076034016469007977829453D-01 pw(14)= 0.24641687279129405797304341158994351D-01 pw(15)= 0.28829130387470289935818007648098355D-01 pw(16)= 0.33772655230285352209194232463306431D-01 pw(17)= 0.39614465986840122572670076622475638D-01 pw(18)= 0.46518617394519992951670269787487787D-01 pw(19)= 0.54675131186708511535131483491430821D-01 pw(20)= 0.64305014007496806948186778346285377D-01 pw(21)= 0.75666179654741774777744798242374952D-01 pw(22)= 0.89060332032660676125924796117040007D-01 pw(23)= 0.10484093752103114356647229133814935D+00 pw(24)= 0.12342248951027967461470307235875341D+00 pw(25)= 0.14529134199630383752180561542530020D+00 pw(26)= 0.17101847250539549716018144547422270D+00 pw(27)= 0.20127464277089058198410341836023683D+00 pw(28)= 0.23684858001359149093932878615193101D+00 pw(29)= 0.27866903348006793962100039913921415D+00 pw(30)= 0.32783191849208153321924464180174769D+00 pw(31)= 0.38563432289935890460881756854144066D+00 pw(32)= 0.45361805217372703197887339399899876D+00 pw(33)= 0.53362686058844350813392769068823926D+00 pw(34)= 0.62788396771362463542546047416846800D+00 pw(35)= 0.73910064578742344795091934329070699D+00 pw(36)= 0.87063402416829911198578365788259413D+00 pw(37)= 0.10267256741807495552845728772900802D+01 pw(38)= 0.12128781106626951287021151112542470D+01 pw(39)= 0.14364778560404412196974965116370614D+01 pw(40)= 0.17078848068460459936312054922566995D+01 pw(41)= 0.20424685786283419841913953641602057D+01 pw(42)= 0.24647555529206493569854377641616308D+01 pw(43)= 0.30179124308683067944200720815335092D+01 pw(44)= 0.37893852356394974569134386395867514D+01 pw(45)= 0.50014251355936200780723745695031871D+01 pw(46)= 0.75499704094498894150628414754712103D+01 endif if(kn == 47) then px( 1)= 0.30234480684949870042066556848012510D-03 px( 2)= 0.15976464953770958135599778441796202D-02 px( 3)= 0.39470145814685269106194100213451950D-02 px( 4)= 0.73844351214347704596731706115099534D-02 px( 5)= 0.11960307325670953208852468939751834D-01 px( 6)= 0.17744140854528926114461559850667081D-01 px( 7)= 0.24827775421109866384949286855042231D-01 px( 8)= 0.33329587337597891764863922994014555D-01 px( 9)= 0.43399840203304717839217570161011672D-01 px(10)= 0.55227290263964079065971805634237348D-01 px(11)= 0.69047097585245923081163450963219921D-01 px(12)= 0.85150014954361349896311981444336255D-01 px(13)= 0.10389275615680304450176721539326430D+00 px(14)= 0.12570943253264044220914087598374078D+00 px(15)= 0.15112403488297752197534393801499475D+00 px(16)= 0.18076413027130191024242456354592003D+00 px(17)= 0.21537618776652269918043941270387835D+00 px(18)= 0.25584316244558279667676325421037561D+00 px(19)= 0.30320509530959575930710602679134976D+00 px(20)= 0.35868352704264273864602902528848421D+00 px(21)= 0.42371052026058185226325968835995444D+00 px(22)= 0.49996309228509504682760172037312828D+00 px(23)= 0.58940391513730639900316144249394630D+00 px(24)= 0.69432925544472178824662119719828653D+00 px(25)= 0.81742530558526965352748082134155990D+00 px(26)= 0.96183429918308909086642705501460506D+00 px(27)= 0.11312321171355587417637105018144043D+01 px(28)= 0.13299194954977380580964549469885521D+01 px(29)= 0.15629294821033111247460192707385455D+01 px(30)= 0.18361545182421012128782235750936341D+01 px(31)= 0.21564975473013180685304927966921050D+01 px(32)= 0.25320530389913426066138968271032273D+01 px(33)= 0.29723260351325192884401956439321237D+01 px(34)= 0.34885007189662000039152029330111157D+01 px(35)= 0.40937753452277820469237089959367401D+01 px(36)= 0.48037889682999426543864264911219419D+01 px(37)= 0.56371796552402367761125198516216112D+01 px(38)= 0.66163382295353580459275111274902267D+01 px(39)= 0.77684648059929853861219213698259439D+01 px(40)= 0.91271156012149482363243828361549091D+01 px(41)= 0.10734585093601096152552856517558275D+02 px(42)= 0.12645801076306643342528896213826369D+02 px(43)= 0.14935178894323617316649392464504258D+02 px(44)= 0.17709887244612807742256277065719222D+02 px(45)= 0.21139166627448714331281414920298006D+02 px(46)= 0.25533898913637103231788330664255958D+02 px(47)= 0.31663433742152343555689779493983534D+02 pw( 1)= 0.77643840612392469558233568878288438D-03 pw( 2)= 0.18178823313702654997790171434491737D-02 pw( 3)= 0.28864536542127938374932216849800024D-02 pw( 4)= 0.39967467153526294501560789189634526D-02 pw( 5)= 0.51665295391631236792192347882343893D-02 pw( 6)= 0.64163743838733321438814922251353746D-02 pw( 7)= 0.77705352297994246418018494260403994D-02 pw( 8)= 0.92580225788462023682293420241402079D-02 pw( 9)= 0.10913810605238600296521875414785753D-01 pw(10)= 0.12780129454852165115348470540659794D-01 pw(11)= 0.14907770873253776058864543333587366D-01 pw(12)= 0.17357325452550337474212111231031977D-01 pw(13)= 0.20200301191038969448754000899427036D-01 pw(14)= 0.23520156080274576647610305543693418D-01 pw(15)= 0.27413389239659681777619137570103249D-01 pw(16)= 0.31990921824324695951826704036400849D-01 pw(17)= 0.37380010931288310349162200884914999D-01 pw(18)= 0.43726873583833196750460928410582440D-01 pw(19)= 0.51200100443073974036149329120700021D-01 pw(20)= 0.59994868260574886373334055836155630D-01 pw(21)= 0.70337945020122803930065727247244319D-01 pw(22)= 0.82493514750755835638795021587104324D-01 pw(23)= 0.96769906495425836064670059167481399D-01 pw(24)= 0.11352737495114584133685628457043583D+00 pw(25)= 0.13318714247714292913023639085868125D+00 pw(26)= 0.15624197763113426788311768418626933D+00 pw(27)= 0.18326866459826594224170442595536027D+00 pw(28)= 0.21494282570862350034472593398023850D+00 pw(29)= 0.25205671631617380517032575867290262D+00 pw(30)= 0.29554084830882541265073842592331588D+00 pw(31)= 0.34649066398539118260401510223685881D+00 pw(32)= 0.40620005573936491411597998731411544D+00 pw(33)= 0.47620444337408185641294547642135994D+00 pw(34)= 0.55833761203594537949491272468091006D+00 pw(35)= 0.65480899160066358211037008014529884D+00 pw(36)= 0.76831227871509708311671525382157320D+00 pw(37)= 0.90218370924525609794334519875989345D+00 pw(38)= 0.10606417731219318086869090064772246D+01 pw(39)= 0.12491658485426170682375819102086492D+01 pw(40)= 0.14751229591934938816623767074938966D+01 pw(41)= 0.17488634335620615325269065049873221D+01 pw(42)= 0.20857683710668100441568568919092486D+01 pw(43)= 0.25104181373755596577440533667319287D+01 pw(44)= 0.30661234529278624717819692903450825D+01 pw(45)= 0.38406927297086597567375854792414220D+01 pw(46)= 0.50574215821071962594952640986635070D+01 pw(47)= 0.76168408553950413361259182112809766D+01 endif if(kn == 48) then px( 1)= 0.29595002899720089598048509729240858D-03 px( 2)= 0.15636631385928177658857961799981344D-02 px( 3)= 0.38621935810659565095543543710661065D-02 px( 4)= 0.72233636458828631437195788212396685D-02 px( 5)= 0.11694254587023519966120947669484770D-01 px( 6)= 0.17339652834546167382576155326885531D-01 px( 7)= 0.24244927054495278219738066751504960D-01 px( 8)= 0.32519777490587042844934209629601974D-01 px( 9)= 0.42303000131579013083618262933841541D-01 px(10)= 0.53768369083049019518863347968872785D-01 px(11)= 0.67131693007024900369022557250738329D-01 px(12)= 0.82659034800333661590098251027713411D-01 px(13)= 0.10067601794995718748717592252167950D+00 px(14)= 0.12157811670283109994038391671204829D+00 px(15)= 0.14584188025331271469532975454293184D+00 px(16)= 0.17403718708094337911584686617663455D+00 px(17)= 0.20684083223970121872293135877750441D+00 px(18)= 0.24505195226053213810882336066380088D+00 px(19)= 0.28960993053758356990356801037005909D+00 px(20)= 0.34161548376800915367159074480126869D+00 px(21)= 0.40235563464585336049157109682672131D+00 px(22)= 0.47333327369938541669100296412222937D+00 px(23)= 0.55630204160312520623134123151678925D+00 px(24)= 0.65330734108265942786541154430622162D+00 px(25)= 0.76673441875356785236785315155850152D+00 px(26)= 0.89936464142274902321479563230619771D+00 px(27)= 0.10544413316663370284059399235987637D+01 px(28)= 0.12357468356208411453551987100600846D+01 px(29)= 0.14476928958143963682846712437006035D+01 px(30)= 0.16954269342764845689137922115223447D+01 px(31)= 0.19849575816646326604339901913933094D+01 px(32)= 0.23233038211583159605827592291675721D+01 px(33)= 0.27186736189401563011050998256085975D+01 px(34)= 0.31806801589007531007613766645355501D+01 px(35)= 0.37206072396727045282926190726802162D+01 px(36)= 0.43517407927213647930655693816847034D+01 px(37)= 0.50897921727561576322594218577457258D+01 px(38)= 0.59534532497729963738598299894774892D+01 px(39)= 0.69651478712196520721782791126144665D+01 px(40)= 0.81520877402662049285349974267562675D+01 px(41)= 0.95478213967711421151781315680800985D+01 px(42)= 0.11194623319536797531467272595329506D+02 px(43)= 0.13147404152263011059682758275653972D+02 px(44)= 0.15480595341123512509584325553694590D+02 px(45)= 0.18301477075836510534702330167968349D+02 px(46)= 0.21779637522565706043537218918652790D+02 px(47)= 0.26226933347488070796043946213342574D+02 px(48)= 0.32415929770269557720899017070958329D+02 pw( 1)= 0.75999449282242525498888775227070420D-03 pw( 2)= 0.17789442907920029044278935841370033D-02 pw( 3)= 0.28233592185581488393945265516117315D-02 pw( 4)= 0.39067912705549311303324714399927545D-02 pw( 5)= 0.50457409167121635114256894882489535D-02 pw( 6)= 0.62592215195201857161143217251824231D-02 pw( 7)= 0.75695311456923674293727515403732119D-02 pw( 8)= 0.90032044940945145010068536558863271D-02 pw( 9)= 0.10592085506839418968886878624905230D-01 pw(10)= 0.12374483314193827446279695880913988D-01 pw(11)= 0.14396352965559528046529852650738501D-01 pw(12)= 0.16712429540159363311802064676696312D-01 pw(13)= 0.19387262265658075348794679025267961D-01 pw(14)= 0.22496156590284673178523069618335189D-01 pw(15)= 0.26126125032895265676414993536188666D-01 pw(16)= 0.30377032282566849853328475248140570D-01 pw(17)= 0.35363150724079551172748521328984452D-01 pw(18)= 0.41215303456842402904128482278539693D-01 pw(19)= 0.48083691328284411416338444917462566D-01 pw(20)= 0.56141427938196717060539102662208221D-01 pw(21)= 0.65588776105316823321919603829156998D-01 pw(22)= 0.76658094133956830129535839504567249D-01 pw(23)= 0.89619543419632664042116217247700679D-01 pw(24)= 0.10478766192717970201342332439078370D+00 pw(25)= 0.12252896123742271255427206161487662D+00 pw(26)= 0.14327075828486752574672706211131092D+00 pw(27)= 0.16751151313821774235835757278858330D+00 pw(28)= 0.19583302163349966411912965960570620D+00 pw(29)= 0.22891492049551029451481007469340092D+00 pw(30)= 0.26755212283797206211340817029488241D+00 pw(31)= 0.31267604416833112127254011348613261D+00 pw(32)= 0.36538085205037423661137648346933768D+00 pw(33)= 0.42695655668634922335366944118783047D+00 pw(34)= 0.49893168999297620297105696955480497D+00 pw(35)= 0.58312983017364951950857474996168896D+00 pw(36)= 0.68174673032193870559875685439839375D+00 pw(37)= 0.79745906091752647870294820280336694D+00 pw(38)= 0.93358322488211662322908533451921218D+00 pw(39)= 0.10943162513760950011430094815688344D+01 pw(40)= 0.12851165678797307366335354072388698D+01 pw(41)= 0.15133343910778260993594764587330245D+01 pw(42)= 0.17893135308834332452949764559455513D+01 pw(43)= 0.21284497101212601640922819767089646D+01 pw(44)= 0.25553800629427160180922388763367066D+01 pw(45)= 0.31135609716998794233456050246781466D+01 pw(46)= 0.38911620012948672120134104867773046D+01 pw(47)= 0.51125134158119019180657428081205730D+01 pw(48)= 0.76826855076385203411408423144047970D+01 endif if(kn == 49) then px( 1)= 0.28982169661609259925974979296199715D-03 px( 2)= 0.15311074628945562334530690364685912D-02 px( 3)= 0.37809891427061498988417968394892015D-02 px( 4)= 0.70693075551075721251308809528074262D-02 px( 5)= 0.11440114051043380640580809174873546D-01 px( 6)= 0.16953896205505568651585337372141638D-01 px( 7)= 0.23690155524198397880316141824091359D-01 px( 8)= 0.31750757826730201808237900276821105D-01 px( 9)= 0.41264185607363735111209847472395680D-01 px(10)= 0.52390788296171869395123759706096667D-01 px(11)= 0.65329088415812943007951010158851832D-01 px(12)= 0.80323145971104464698417160245071838D-01 px(13)= 0.97670923692398180646763841694521778D-01 px(14)= 0.11773356193272553739176999855177642D+00 px(15)= 0.14094549927124676527452589226795674D+00 px(16)= 0.16782548211787615810300942831732404D+00 px(17)= 0.19898867709139685594599685847717735D+00 px(18)= 0.23516028351061490409755316887724481D+00 px(19)= 0.27719118480638011914316315022611666D+00 px(20)= 0.32607625000818758221137748238031822D+00 px(21)= 0.38297591208948031388506643958671483D+00 px(22)= 0.44924164526126338307000295982995931D+00 px(23)= 0.52644597452520216232192817378809657D+00 px(24)= 0.61641769981161764547143482902113440D+00 px(25)= 0.72128311119138160917726410382682506D+00 px(26)= 0.84351411110478227605310059636301640D+00 px(27)= 0.98598434482611919288728229535556820D+00 px(28)= 0.11520346774611530676609320335187635D+01 px(29)= 0.13455496592189661370306885171963069D+01 px(30)= 0.15710470166859281003411527674326210D+01 px(31)= 0.18337827389082834345983893278310805D+01 px(32)= 0.21398750605157030327208430120547271D+01 px(33)= 0.24964516861943417767039670584804599D+01 px(34)= 0.29118261213763337159423664681275174D+01 px(35)= 0.33957112485642962686719816570055312D+01 px(36)= 0.39594817726282308325228740791813504D+01 px(37)= 0.46165026215025079679688539374253711D+01 px(38)= 0.53825491684099448048962771604007379D+01 px(39)= 0.62763596401674826758369077814162276D+01 px(40)= 0.73203847840971806343130509762279760D+01 px(41)= 0.85418435921307030922239809237588315D+01 px(42)= 0.99742749209607261981040189301013931D+01 px(43)= 0.11659933902343682924575082774292738D+02 px(44)= 0.13653717512175632633212031175648009D+02 px(45)= 0.16030079451319704520212844485652403D+02 px(46)= 0.18896419514536338819621757969794054D+02 px(47)= 0.22422681781072229358731374027395797D+02 px(48)= 0.26921701181159762662101522272189023D+02 px(49)= 0.33169237709310133472812163437610434D+02 pw( 1)= 0.74423705557468321912970974468971512D-03 pw( 2)= 0.17416585473194369192981311717828790D-02 pw( 3)= 0.27630202767273380717880972293549723D-02 pw( 4)= 0.38209254857123832686825908868042634D-02 pw( 5)= 0.49307262850810818969143173604709699D-02 pw( 6)= 0.61100327216620297105479543777143453D-02 pw( 7)= 0.73793929142489472766538930130422414D-02 pw( 8)= 0.87631380820224889920133086400922484D-02 pw( 9)= 0.10290337290113942038466358200627605D-01 pw(10)= 0.11995832288470777205381700382547014D-01 pw(11)= 0.13921304955008894938778083468431898D-01 pw(12)= 0.16116315842092009170407309532189491D-01 pw(13)= 0.18639261057732707055179140040607199D-01 pw(14)= 0.21558238862705300435120252889679016D-01 pw(15)= 0.24951892641527327511221421263371520D-01 pw(16)= 0.28910375260277562929269397616107752D-01 pw(17)= 0.33536621862509534402237961505810400D-01 pw(18)= 0.38948101356497020534071631819477111D-01 pw(19)= 0.45279154574446597766189875771988559D-01 pw(20)= 0.52683958194920854977905259654150493D-01 pw(21)= 0.61340113116439272718820743217394536D-01 pw(22)= 0.71452855489322219691816819653732876D-01 pw(23)= 0.83259918269799951973839847297358939D-01 pw(24)= 0.97037114546374637815371486877102608D-01 pw(25)= 0.11310475960635753107742085931930780D+00 pw(26)= 0.13183509368952202468340313538628788D+00 pw(27)= 0.15366091498274177979540995552638069D+00 pw(28)= 0.17908568983953526314195097583061572D+00 pw(29)= 0.20869548441677582027963091462587493D+00 pw(30)= 0.24317317246706239890716235938537564D+00 pw(31)= 0.28331553768501980083448486564952605D+00 pw(32)= 0.33005413638688135108429388605654924D+00 pw(33)= 0.38448116653084696134266394851745611D+00 pw(34)= 0.44788218293156059076871251650381853D+00 pw(35)= 0.52177844169743715495966266074704591D+00 pw(36)= 0.60798318304777180959943540325649013D+00 pw(37)= 0.70867868475109945308012661652305988D+00 pw(38)= 0.82652519802949145510247997374762292D+00 pw(39)= 0.96482036576439726113478189858839344D+00 pw(40)= 0.11277413304728328935012105843530012D+01 pw(41)= 0.13207276384535346696169033036111123D+01 pw(42)= 0.15511151994361137315814825047961978D+01 pw(43)= 0.18292440906220512275179521250816934D+01 pw(44)= 0.21705274773423284009902208179302011D+01 pw(45)= 0.25996616983900981131162894691162348D+01 pw(46)= 0.31602501106700710441030906881720498D+01 pw(47)= 0.39408219589198821554199569326106068D+01 pw(48)= 0.51667323905056736314902652284285907D+01 pw(49)= 0.77475392524477876553320371372226975D+01 endif if(kn == 50) then px( 1)= 0.28394351112953297748994559783102511D-03 px( 2)= 0.14998911954688725774856401484033629D-02 px( 3)= 0.37031733634109224832474380329849766D-02 px( 4)= 0.69218127312350228406485064567062889D-02 px( 5)= 0.11197087943784824700478952929697149D-01 px( 6)= 0.16585564985245590131106268275448670D-01 px( 7)= 0.23161412500517665834595664639261402D-01 px( 8)= 0.31019403043677038055911010779170235D-01 px( 9)= 0.40278717647655643037391307728658037D-01 px(10)= 0.51087642190675989042234002017798487D-01 px(11)= 0.63629213809160599368347959049041399D-01 px(12)= 0.78127829475675329032296849094039453D-01 px(13)= 0.94856775739499734452627500076424815D-01 px(14)= 0.11414660148335876745918230546444594D+00 px(15)= 0.13639426440178507981483041317230735D+00 px(16)= 0.16207305783142124363194134470205347D+00 px(17)= 0.19174346191330080395615598185222217D+00 px(18)= 0.22606522557261662878988725676839652D+00 px(19)= 0.26581112483702385355663297234020894D+00 px(20)= 0.31188292620679003206265405632135533D+00 px(21)= 0.36533011131301634013423764015010912D+00 px(22)= 0.42737191711071555589396273204369958D+00 px(23)= 0.49942324705020639374541286536052638D+00 px(24)= 0.58312503667951418472684968751768941D+00 px(25)= 0.68037972242344487980438298325566643D+00 px(26)= 0.79339256658260940896953648094143840D+00 px(27)= 0.92471973446804368904394005417532194D+00 px(28)= 0.10773242035057135225415445929049064D+01 px(29)= 0.12546408175407001854792111537007726D+01 px(30)= 0.14606520990918797361653158063467201D+01 px(31)= 0.16999768257560608388590285583482666D+01 px(32)= 0.19779739082773843717702150700803880D+01 px(33)= 0.23008648456607864889580088643288349D+01 px(34)= 0.26758790850855905290663568936243531D+01 px(35)= 0.31114281531421848676256035865658428D+01 px(36)= 0.36173167280945029265548597355573382D+01 px(37)= 0.42050023489136640359196188798116726D+01 px(38)= 0.48879209793922610146974780441291671D+01 px(39)= 0.56819045073984933891246336517741761D+01 px(40)= 0.66057308705566818707545720531514149D+01 px(41)= 0.76818723662188017987959388336177329D+01 px(42)= 0.89375516656298253147474053069187414D+01 px(43)= 0.10406296477480503239729452647809424D+02 px(44)= 0.12130343567869783578305872825995901D+02 px(45)= 0.14164579787764828196349642136898031D+02 px(46)= 0.16583487005376427804066458589286026D+02 px(47)= 0.19494592188944424125485472332517264D+02 px(48)= 0.23068202782732093092557399540639023D+02 px(49)= 0.27618134557703623179690912010041751D+02 px(50)= 0.33923321036009768333728618541703920D+02 pw( 1)= 0.72912399684308635017096115410335056D-03 pw( 2)= 0.17059216228519449314704147393870548D-02 pw( 3)= 0.27052579385463033654518158126252911D-02 pw( 4)= 0.37388707495255014610097719618737042D-02 pw( 5)= 0.48210691945239681765906911252349642D-02 pw( 6)= 0.59681965658636724574936823069437344D-02 pw( 7)= 0.71992306962236770905536136519431856D-02 pw( 8)= 0.85365357689533034566484478187242343D-02 pw( 9)= 0.10006713677868850439161417859632759D-01 pw(10)= 0.11641531351319812896113767691847514D-01 pw(11)= 0.13478885680498147705267761047018866D-01 pw(12)= 0.15563753671054168683182913698539199D-01 pw(13)= 0.17949077884564351780048811341841315D-01 pw(14)= 0.20696568103487745734831198958981091D-01 pw(15)= 0.23877459843864173187990416648243479D-01 pw(16)= 0.27573340091582106763900700105376174D-01 pw(17)= 0.31877198204074685512995246247087960D-01 pw(18)= 0.36894860399462428730109186000241340D-01 pw(19)= 0.42746921785947037355880124311792745D-01 pw(20)= 0.49571228532988571977201451960147272D-01 pw(21)= 0.57525917359503163899312028414966321D-01 pw(22)= 0.66793006913272852902897497204087823D-01 pw(23)= 0.77582552855288975335680322806095329D-01 pw(24)= 0.90137412508095941124740779645748160D-01 pw(25)= 0.10473870396294021438411474581832967D+00 pw(26)= 0.12171208319009365070220694175921390D+00 pw(27)= 0.14143500171709279543618029697282644D+00 pw(28)= 0.16434515151851001863886624876712371D+00 pw(29)= 0.19095035999365251682074028234920175D+00 pw(30)= 0.22184027575178191861381490980142531D+00 pw(31)= 0.25770029856713080526288855613179455D+00 pw(32)= 0.29932837398793730342885176518781178D+00 pw(33)= 0.34765552544247195237609202772613096D+00 pw(34)= 0.40377138372726537143521552364635440D+00 pw(35)= 0.46895657668751681273934682099459395D+00 pw(36)= 0.54472479692767961940426388856919793D+00 pw(37)= 0.63287890678130081055700714208328112D+00 pw(38)= 0.73558798250487807944749198073740843D+00 pw(39)= 0.85549650522124124655227075039375323D+00 pw(40)= 0.99588443073362582872294183483256617D+00 pw(41)= 0.11609105355219986209989146786182259D+01 pw(42)= 0.13559974384949635725484334023159422D+01 pw(43)= 0.15884690610914334611993355370110858D+01 pw(44)= 0.18686642910659719608475187905997900D+01 pw(45)= 0.22120162660997500537540215058314098D+01 pw(46)= 0.26432826564193229543032457728289448D+01 pw(47)= 0.32062148179068205963629824250927723D+01 pw(48)= 0.39897000025706165355011208836568943D+01 pw(49)= 0.52201085267504392582124308457577559D+01 pw(50)= 0.78114350904888610285435916161990246D+01 endif if(kn == 51) then px( 1)= 0.27830048331694745146626670725003848D-03 px( 2)= 0.14699332467589495012214296420135614D-02 px( 3)= 0.36285373076700958382889506232860957D-02 px( 4)= 0.67804640421568805932750563900953938D-02 px( 5)= 0.10964449641475153555650317586921338D-01 px( 6)= 0.16233474841656748209131399424045480D-01 px( 7)= 0.22656849606742837535759660703189982D-01 px( 8)= 0.30322907994226545082257492807954794D-01 px( 9)= 0.39342419929775285730416663052397862D-01 px(10)= 0.49852801135275356633188650023787799D-01 px(11)= 0.62023178388698049878991488778075058D-01 px(12)= 0.76060329272036397821127225875497380D-01 px(13)= 0.92215469045402426815676149451909456D-01 px(14)= 0.11079181963288772179472869891025245D+00 px(15)= 0.13215289192145648970655359123013550D+00 px(16)= 0.15673146375949390138182262372756365D+00 px(17)= 0.18503934411172685168403222212810987D+00 px(18)= 0.21767815425667758980667415659377157D+00 px(19)= 0.25535148902919646272821292167480645D+00 px(20)= 0.29887891101338956958304222194317216D+00 px(21)= 0.34921226930606420176060402127989888D+00 px(22)= 0.40745483836472093899131085922052085D+00 px(23)= 0.47488376920818361679977841816170633D+00 px(24)= 0.55297635865326739663234570169538373D+00 px(25)= 0.64344068535303042620990947995897496D+00 px(26)= 0.74825123790612149826635700308884120D+00 px(27)= 0.86969026995696913003053787424248180D+00 px(28)= 0.10103957605313364799613553988071921D+01 px(29)= 0.11734170393027801618266450011528511D+01 px(30)= 0.13622793663980858168640978903164547D+01 px(31)= 0.15810590528845442660473438585783950D+01 px(32)= 0.18344711002533369402909515294518176D+01 px(33)= 0.21279718700902070387593931590109607D+01 px(34)= 0.24678800386227544163678584032999521D+01 px(35)= 0.28615201544104645116093866929518600D+01 px(36)= 0.33173946748043709269495501699195293D+01 px(37)= 0.38453926882082167185869634333011899D+01 px(38)= 0.44570470958112522799784043488271277D+01 px(39)= 0.51658576054751924442339769813379872D+01 px(40)= 0.59877058293844537789530450556075720D+01 px(41)= 0.69414034941300311714983901016833412D+01 px(42)= 0.80494397879808445218602940428136405D+01 px(43)= 0.93390380570666107887290025527994856D+01 px(44)= 0.10843713859839632308899371210210092D+02 px(45)= 0.12605686843057786008572981971452711D+02 px(46)= 0.14679837296994134584444426535907765D+02 px(47)= 0.17140680920657630892046419784075754D+02 px(48)= 0.20095878907672599896988947474029035D+02 px(49)= 0.23716108785958653467610019526488283D+02 px(50)= 0.28316168939449414612178766745269557D+02 px(51)= 0.34678144812502309409979036489309933D+02 pw( 1)= 0.71461661125073618577714141168068574D-03 pw( 2)= 0.16716385878603382275615092392545966D-02 pw( 3)= 0.26499087137809206936489894716951881D-02 pw( 4)= 0.36603737280291944817450300201489801D-02 pw( 5)= 0.47163932617577667464231453856574222D-02 pw( 6)= 0.58331641163766286245746932185477944D-02 pw( 7)= 0.70282510906775725331369422805168084D-02 pw( 8)= 0.83222573157223186581625603590243717D-02 pw( 9)= 0.97395848045625290059070106665033066D-02 pw(10)= 0.11309266338983814689829245251610443D-01 pw(11)= 0.13065837815189701273276681449362080D-01 pw(12)= 0.15050206824622500427636027066505286D-01 pw(13)= 0.17310471604431563174843365788224820D-01 pw(14)= 0.19902665286202140668402395991957144D-01 pw(15)= 0.22891446750016473901306940204721219D-01 pw(16)= 0.26350819616702910168573443501795867D-01 pw(17)= 0.30365009714194435950502154476602598D-01 pw(18)= 0.35029644330122852911457703936925401D-01 pw(19)= 0.40453348181743022646044235704229779D-01 pw(20)= 0.46759819486523129479791042090399526D-01 pw(21)= 0.54090403179921190709407057449782309D-01 pw(22)= 0.62607156912964304588823654347725686D-01 pw(23)= 0.72496411785130069944054386511386143D-01 pw(24)= 0.83972854815470973907373202544753383D-01 pw(25)= 0.97284192841846608857881098157165865D-01 pw(26)= 0.11271649103721755058596361082284142D+00 pw(27)= 0.13060031219247571052268358514865611D+00 pw(28)= 0.15131781797811823631871970343701060D+00 pw(29)= 0.17531103556726408969705872673699634D+00 pw(30)= 0.20309154904134215752202092778295388D+00 pw(31)= 0.23525195397891395078569762059044835D+00 pw(32)= 0.27247952854009146289412622775860388D+00 pw(33)= 0.31557274490479512420214647476118810D+00 pw(34)= 0.36546150205090068791751615370418030D+00 pw(35)= 0.42323235431744446559543345018447882D+00 pw(36)= 0.49016062156217930068156275755723687D+00 pw(37)= 0.56775223265564612092706940030068368D+00 pw(38)= 0.65779970939872780221136201150769308D+00 pw(39)= 0.76245925865498574135551621597788489D+00 pw(40)= 0.88436027001142532199927186614862192D+00 pw(41)= 0.10267660753266581074365019471728486D+01 pw(42)= 0.11938185471963720076518527335025432D+01 pw(43)= 0.13909252171844327541246452342529830D+01 pw(44)= 0.16254001662180292675140925291992103D+01 pw(45)= 0.19075834129441296076092154965785291D+01 pw(46)= 0.22529303361525593567401491175421270D+01 pw(47)= 0.26862617892200971765670039600369766D+01 pw(48)= 0.32514778994133779406256785815727141D+01 pw(49)= 0.40378220858095016239167419409137174D+01 pw(50)= 0.52726701882528895779137444037618021D+01 pw(51)= 0.78744042074131644922750515876542347D+01 endif if(kn == 52) then px( 1)= 0.27287878963778979318704099764976979D-03 px( 2)= 0.14411589143135589309910830756029883D-02 px( 3)= 0.35568888680936775757132750276695479D-02 px( 4)= 0.66448808369926751816655531142947976D-02 px( 5)= 0.10741535203421646235306609286779033D-01 px( 6)= 0.15896548124765745985567116234974430D-01 px( 7)= 0.22174792928607557748215031029525379D-01 px( 8)= 0.29658745389012720604963104746455902D-01 px( 9)= 0.38451550078535438960644609304592703D-01 px(10)= 0.48680802154773981897502480211717432D-01 px(11)= 0.60503099784552369897160088385145451D-01 px(12)= 0.74109391214600302911242894598461603D-01 px(13)= 0.89731100249233358933686871661989877D-01 px(14)= 0.10764697753584156876969725074282997D+00 px(15)= 0.12819061301398605430851761152295284D+00 px(16)= 0.15175857698395808054368327545045674D+00 px(17)= 0.17881924018609623916197948354619579D+00 px(18)= 0.20992244196465392763256291141326856D+00 px(19)= 0.24571029757551810503161176844891960D+00 px(20)= 0.28692952833595684927481466342699473D+00 px(21)= 0.33444574647578471028054731992057917D+00 px(22)= 0.38926013793139080772351691924522347D+00 px(23)= 0.45252898276941636881394275842894023D+00 px(24)= 0.52558645699160000314972991962565110D+00 px(25)= 0.60997118585865879765197048254341330D+00 px(26)= 0.70745707342364955349644867464416164D+00 px(27)= 0.82008901627275511415852311384357046D+00 px(28)= 0.95022422122473475017786104441461093D+00 px(29)= 0.11005799888944176702824780847485411D+01 px(30)= 0.12742890037078181125625630187828027D+01 px(31)= 0.14749633979156047676958663456164965D+01 px(32)= 0.17067691516542664863528589999065341D+01 px(33)= 0.19745127831074488312044849464771686D+01 px(34)= 0.22837428183447160072986023000468876D+01 px(35)= 0.26408692804764055817543358579323038D+01 px(36)= 0.30533055131576702465080896333143573D+01 px(37)= 0.35296382295469342100204889068765045D+01 px(38)= 0.40798340368281393790208425276818839D+01 px(39)= 0.47154942919829600315975357986809138D+01 px(40)= 0.54501757769677042873771351203731296D+01 px(41)= 0.62998036929575447450649046764701569D+01 px(42)= 0.72832182898545812637798931719272845D+01 px(43)= 0.84229216047310103819935078476256484D+01 px(44)= 0.97461351851146406033204591955381092D+01 px(45)= 0.11286361832018459964955857919026558D+02 px(46)= 0.13085805530780086242892657357654051D+02 px(47)= 0.15199343565107891341827069072222156D+02 px(48)= 0.17701530875675334700619075035054618D+02 px(49)= 0.20700169445006682515691632852528091D+02 px(50)= 0.24366312928914848142376439425799257D+02 px(51)= 0.29015743374923417716784066471530138D+02 px(52)= 0.35433676271462821390664880501380081D+02 pw( 1)= 0.70067921248512656450750262380470989D-03 pw( 2)= 0.16387221028734144344416061643064582D-02 pw( 3)= 0.25968227302892772688118502909161922D-02 pw( 4)= 0.35852033221618217540588075672036645D-02 pw( 5)= 0.46163571334057459414651619546435755D-02 pw( 6)= 0.57044407177542779516540853577376776D-02 pw( 7)= 0.68657439258466701284209801337979038D-02 pw( 8)= 0.81192888642852760066695573485214022D-02 pw( 9)= 0.94875105621027290016976460295608743D-02 pw(10)= 0.10997004127430955685924352255220372D-01 pw(11)= 0.12679313613778005716132640549939369D-01 pw(12)= 0.14571725519850453422967526162847044D-01 pw(13)= 0.16718025683719221072849622604121732D-01 pw(14)= 0.19169191632602931509237238888017571D-01 pw(15)= 0.21984027773632325146538486813698425D-01 pw(16)= 0.25229801526425832500489421276402268D-01 pw(17)= 0.28982985579859711073310312330962579D-01 pw(18)= 0.33330232727989722055601631534296414D-01 pw(19)= 0.38369695026986305327273292677722862D-01 pw(20)= 0.44212758195453754037273486501473222D-01 pw(21)= 0.50986218113528798819802588773272107D-01 pw(22)= 0.58834899219859082186151202608595314D-01 pw(23)= 0.67924711805560266218170048520749527D-01 pw(24)= 0.78446161793212774417972991998090425D-01 pw(25)= 0.90618353089338093281832862102708959D-01 pw(26)= 0.10469355154807580861182066828267783D+00 pw(27)= 0.12096240801949377693281668581524884D+00 pw(28)= 0.13975996681192581185584791335037507D+00 pw(29)= 0.16147261854647111561641477797041919D+00 pw(30)= 0.18654619771836799217214159212739546D+00 pw(31)= 0.21549548172910307786548214775429476D+00 pw(32)= 0.24891542853693721010435838752243091D+00 pw(33)= 0.28749460731095023155833868404490821D+00 pw(34)= 0.33203145035164386811290281590906319D+00 pw(35)= 0.38345421620808062938143753495150014D+00 pw(36)= 0.44284595340052667020006768746408026D+00 pw(37)= 0.51147637334768443075077758376770258D+00 pw(38)= 0.59084351705391666304914198628651331D+00 pw(39)= 0.68272966822652633355509618616923460D+00 pw(40)= 0.78927854268555272214405511831212374D+00 pw(41)= 0.91310513570381533776392939171880649D+00 pw(42)= 0.10574572006171471782817226512789618D+01 pw(43)= 0.12264611065174215544931924431769419D+01 pw(44)= 0.14255110268002246494143307711209540D+01 pw(45)= 0.16619131890762190850734830449377183D+01 pw(46)= 0.19460108584649183568553387986228161D+01 pw(47)= 0.22932836878593317486878267058034769D+01 pw(48)= 0.27286173208169332405445956554845995D+01 pw(49)= 0.32960612083291505532244371231002347D+01 pw(50)= 0.40852129572893008083223241182607456D+01 pw(51)= 0.53244443718708726283429813785502501D+01 pw(52)= 0.79364763274033460235909669710486787D+01 endif if(kn == 53) then px( 1)= 0.26766570337770727528170071246520492D-03 px( 2)= 0.14134994888717316196512141359660423D-02 px( 3)= 0.34880516519107403970758408932728686D-02 px( 4)= 0.65147144546990128201893001657184119D-02 px( 5)= 0.10527738385818098548917273507385571D-01 px( 6)= 0.15573804518451021912970981414950172D-01 px( 7)= 0.21713726252830234938777297490158659D-01 px( 8)= 0.29024636763636674603190500526652300D-01 px( 9)= 0.37602750842526664184644761079770188D-01 px(10)= 0.47566769031392334409003814047662918D-01 px(11)= 0.59061976687480610814082596844534784D-01 px(12)= 0.72265065129161553717681820608077034D-01 px(13)= 0.87389667514901234333023139285043850D-01 px(14)= 0.10469256811716735138855696367380459D+00 px(15)= 0.12448052659100388617653071564391793D+00 px(16)= 0.14711767656647036665309334227739246D+00 px(17)= 0.17303351979129595018460716414084922D+00 px(18)= 0.20273163525968242510069482779745799D+00 px(19)= 0.23679933260205764383581082765297944D+00 px(20)= 0.27591857089423386003627193488624766D+00 px(21)= 0.32087851933017891678519245554349762D+00 px(22)= 0.37259015544714682612264560035248998D+00 px(23)= 0.43210329558213462840685308411772863D+00 px(24)= 0.50062645115169427006331566594320087D+00 px(25)= 0.57954991863929172590111454477122563D+00 px(26)= 0.67047254853929904297053555520671948D+00 px(27)= 0.77523270078396767247020251586833006D+00 px(28)= 0.89594398099521297070364552635590329D+00 px(29)= 0.10350364637633983911134434941276054D+01 px(30)= 0.11953042494029295972874450876803876D+01 px(31)= 0.13799603766985451495079757379930050D+01 px(32)= 0.15927003388200029769046949954648636D+01 px(33)= 0.18377757429440148519213952318668567D+01 px(34)= 0.21200800469036983170430724963400520D+01 px(35)= 0.24452488452376621255574183769872919D+01 px(36)= 0.28197779343346462148849901776278631D+01 px(37)= 0.32511634739679835132078134711319616D+01 px(38)= 0.37480701572008120067601493824866792D+01 px(39)= 0.43205356864545827578744429205984365D+01 px(40)= 0.49802234963192223418120333779580923D+01 px(41)= 0.57407413466949074338019856932754499D+01 px(42)= 0.66180524896462577279982649502155498D+01 px(43)= 0.76310210235736203134564527928377033D+01 px(44)= 0.88021583399572758584848067436385530D+01 px(45)= 0.10158682176971824690390966321630474D+02 px(46)= 0.11734082305033337839638441179290729D+02 px(47)= 0.13570548670500422261838718291627263D+02 px(48)= 0.15722959067717953266995872699981198D+02 px(49)= 0.18265912835593835999181449267925846D+02 px(50)= 0.21307358846087134932506642776378880D+02 px(51)= 0.25018732302848078195180809407087663D+02 px(52)= 0.29716799310767845023829953456809187D+02 px(53)= 0.36189883296712405656605145166567620D+02 pw( 1)= 0.68727895311546056672417632556060663D-03 pw( 2)= 0.16070919274300689247610198780862261D-02 pw( 3)= 0.25458627429238886643700982329323737D-02 pw( 4)= 0.35131488282427671750845547282299960D-02 pw( 5)= 0.45206512132016346669133873690489887D-02 pw( 6)= 0.55815803493477684696883612785461534D-02 pw( 7)= 0.67110727810055987477008256080221629D-02 pw( 8)= 0.79267274337364857488746447630284210D-02 pw( 9)= 0.92492158987355566092832344937099689D-02 pw(10)= 0.10702954335651349887056984538693118D-01 pw(11)= 0.12316817159979657159477748940914048D-01 pw(12)= 0.14124861608422353998695630535116428D-01 pw(13)= 0.16167026688242225669124227980203198D-01 pw(14)= 0.18489777850309322975434696546792003D-01 pw(15)= 0.21146695079329887928180449259296579D-01 pw(16)= 0.24199043898015304232347701717858443D-01 pw(17)= 0.27716412274949780256699383093693372D-01 pw(18)= 0.31777522531875989191876025347365721D-01 pw(19)= 0.36471323604726302437811675512366006D-01 pw(20)= 0.41898438814168148316223242028468085D-01 pw(21)= 0.48173004736710585958446082731843080D-01 pw(22)= 0.55424906910282799399495351801946886D-01 pw(23)= 0.63802408146079784845031445360740918D-01 pw(24)= 0.73475174123291445512755683573657914D-01 pw(25)= 0.84637721415891914195614185274215305D-01 pw(26)= 0.97513337772431529356043555523731762D-01 pw(27)= 0.11235854926743224508497153739859653D+00 pw(28)= 0.12946823338997306958433565807904794D+00 pw(29)= 0.14918150326264123120255847449750618D+00 pw(30)= 0.17188851951158054500285261747356087D+00 pw(31)= 0.19803842749441616169319688491554627D+00 pw(32)= 0.22814867480320173542334621460640035D+00 pw(33)= 0.26281604587933027973782593098613157D+00 pw(34)= 0.30272987012943215567370818850475517D+00 pw(35)= 0.34868803701893003485156344297085159D+00 pw(36)= 0.40161671758475143724478782201274920D+00 pw(37)= 0.46259509691660897469854774936577795D+00 pw(38)= 0.53288704858998218510998379047232847D+00 pw(39)= 0.61398266720080789199956346065784397D+00 pw(40)= 0.70765415497287477021582999321525042D+00 pw(41)= 0.81603315079286754570846341816085723D+00 pw(42)= 0.94172096259934976721215747985393842D+00 pw(43)= 0.10879507869255648374416119995114567D+01 pw(44)= 0.12588348263164235013060998002290594D+01 pw(45)= 0.14597555182997943253538598754860232D+01 pw(46)= 0.16980130743144824162948847512548702D+01 pw(47)= 0.19839559340047588104729344306844787D+01 pw(48)= 0.23330898446405588037915551380406672D+01 pw(49)= 0.27703666290115585782188239169095417D+01 pw(50)= 0.33399854209196729287026099030910255D+01 pw(51)= 0.41318959182038353492816091595673578D+01 pw(52)= 0.53754564214506164841297568531690314D+01 pw(53)= 0.79976793171584998097855897868836215D+01 endif if(kn == 54) then px( 1)= 0.26264930117348429139290996151281804D-03 px( 2)= 0.13868906738912660879236605780496720D-02 px( 3)= 0.34218609389365101881877496771598208D-02 px( 4)= 0.63896402666404078488978957960735342D-02 px( 5)= 0.10322496845387460828947292469844905D-01 px( 6)= 0.15264338738352449380895430335814458D-01 px( 7)= 0.21272256455056810596723516130341971D-01 px( 8)= 0.28418500058997028295178690126035519D-01 px( 9)= 0.36792971921502915811121828397263107D-01 px(10)= 0.46506297013822420204383294802715589D-01 px(11)= 0.57693520466708188814704660142883650D-01 px(12)= 0.70518461365129452425223403139712676D-01 px(13)= 0.85178722402024364366080809274553805D-01 px(14)= 0.10191132396313916367597436543864246D+00 px(15)= 0.12099891148146303511007328280200670D+00 px(16)= 0.14277649208960370764126858545635037D+00 px(17)= 0.16763870128060588007507633768412165D+00 px(18)= 0.19604767989373694212165892917330544D+00 px(19)= 0.22854173844903711798992185084177464D+00 px(20)= 0.26574507414867220998786541508194950D+00 px(21)= 0.30837886575038189865518112878881341D+00 px(22)= 0.35727409810156122358477142059464743D+00 px(23)= 0.41338647141242328011007195602712556D+00 px(24)= 0.47781374735909608618161123128437916D+00 px(25)= 0.55181589013188334829869817262449587D+00 px(26)= 0.63683838468354892203676383796234712D+00 px(27)= 0.73453915990617498625433330235628987D+00 px(28)= 0.84681961134902351472977037719948889D+00 px(29)= 0.97586030619425103922072317930864173D+00 px(30)= 0.11241620640819289778534857523108689D+01 px(31)= 0.12945932455227004001780815602771556D+01 px(32)= 0.14904442534576446040956072788546865D+01 px(33)= 0.17154904765677712078499252639933687D+01 px(34)= 0.19740651959466252026766816200100743D+01 px(35)= 0.22711443710983615908928413364407126D+01 px(36)= 0.26124457644974208978288838251819154D+01 px(37)= 0.30045456290378285221329470833486270D+01 px(38)= 0.34550172827009750892780305838794194D+01 px(39)= 0.39725975078115629937328151923773107D+01 px(40)= 0.45673891239659119753724152909459628D+01 px(41)= 0.52511117619579365605498903719507942D+01 px(42)= 0.60374185967841005869825918871706947D+01 px(43)= 0.69423059418930191122711841795147301D+01 px(44)= 0.79846576055279832356713682899398131D+01 px(45)= 0.91869913294368492995853064476380612D+01 px(46)= 0.10576519438659101773107722114056823D+02 px(47)= 0.12186718685254033866362337537527451D+02 px(48)= 0.14059766727898227283287996455084238D+02 px(49)= 0.16250545334714196738451761057164415D+02 px(50)= 0.18833703150856317701270861469808901D+02 px(51)= 0.21917341606064316865260155485126217D+02 px(52)= 0.25673282302478359060862571209297198D+02 px(53)= 0.30419275213506007788817412536110986D+02 px(54)= 0.36946729449797287732704130194371723D+02 pw( 1)= 0.67438506760335604670255898997892204D-03 pw( 2)= 0.15766730795758068292367252096595575D-02 pw( 3)= 0.24969010052497357618191188751223522D-02 pw( 4)= 0.34440151585437669876044394575278031D-02 pw( 5)= 0.44289906416819842278218395665719176D-02 pw( 6)= 0.54641754472827296169646638159218540D-02 pw( 7)= 0.65636602656678083773300472655876417D-02 pw( 8)= 0.77437596216345299454674361542457447D-02 pw( 9)= 0.90235600454359303552602178356724465D-02 pw(10)= 0.10425525098028000202217706397525802D-01 pw(11)= 0.11976141415278903324803398081755125D-01 pw(12)= 0.13706580129463991816022845593243222D-01 pw(13)= 0.15653341765432086164765180782288484D-01 pw(14)= 0.17858856637993859978963097726835278D-01 pw(15)= 0.20372031993532375434976430093094102D-01 pw(16)= 0.23248770947110602095264163700609205D-01 pw(17)= 0.26552527146765384924391807859062013D-01 pw(18)= 0.30354987338193146683949319082938468D-01 pw(19)= 0.34736978572221172926784909895879575D-01 pw(20)= 0.39789676392153673565656352708108709D-01 pw(21)= 0.45616156632160377923066059864692116D-01 pw(22)= 0.52333303181858472447283586460111768D-01 pw(23)= 0.60074068936523280823710913114576385D-01 pw(24)= 0.68990089360969502777474092821797731D-01 pw(25)= 0.79254662793149992222714102849062817D-01 pw(26)= 0.91066132125499050058268572358948574D-01 pw(27)= 0.10465172413589772775444532528313942D+00 pw(28)= 0.12027192389960804141840562034167157D+00 pw(29)= 0.13822548329913942877038198233392259D+00 pw(30)= 0.15885518710020893698686679081438881D+00 pw(31)= 0.18255453080015552034691247423767820D+00 pw(32)= 0.20977550590982571093431208426850228D+00 pw(33)= 0.24103774649612254567565390373246475D+00 pw(34)= 0.27693937431815337409878200394680401D+00 pw(35)= 0.31817000170668241587144774061721975D+00 pw(36)= 0.36552653149467718606906358503261169D+00 pw(37)= 0.41993266332639492829188554992634159D+00 pw(38)= 0.48246342603227571148223509952223773D+00 pw(39)= 0.55437668888757955166034857478955110D+00 pw(40)= 0.63715459820483206603034925190427611D+00 pw(41)= 0.73255947628580611457525194256778522D+00 pw(42)= 0.84271132620425470830602701627255624D+00 pw(43)= 0.97019847802255398271823872088809738D+00 pw(44)= 0.11182405648635278467279403261340421D+01 pw(45)= 0.12909368955309583178279432436240182D+01 pw(46)= 0.14936596913948188663729129981816013D+01 pw(47)= 0.17337048448489904526596452227676677D+01 pw(48)= 0.20214277264670434357889736680445585D+01 pw(49)= 0.23723618064324051170579931680799604D+01 pw(50)= 0.28115262822357354520836275890201874D+01 pw(51)= 0.33832701615264074051804266553052254D+01 pw(52)= 0.41778930411553237976334045242367218D+01 pw(53)= 0.54257303561036728308093456793849096D+01 pw(54)= 0.80580396891998440461864612470334815D+01 endif if(kn == 55) then px( 1)= 0.25781894164194012434309377930977151D-03 px( 2)= 0.13612751031594850206775668181403743D-02 px( 3)= 0.33581698458852455723214904600493989D-02 px( 4)= 0.62693690413467873882583513720977616D-02 px( 5)= 0.10125310136665687971355854015542415D-01 px( 6)= 0.14967346351298576942771412456996075D-01 px( 7)= 0.20849147888131304033053596047200679D-01 px( 8)= 0.27838492572990899694403556585128016D-01 px( 9)= 0.36019520279673976527480271121267550D-01 px(10)= 0.45495507499439646885138144349015201D-01 px(11)= 0.56392208694907062019327988961512485D-01 px(12)= 0.68861794220674272839206633722494427D-01 px(13)= 0.83087389784370585294971502938757785D-01 px(14)= 0.99288194535557030324060332733237417D-01 px(15)= 0.11772513411433556959001042015562167D+00 px(16)= 0.13870700468575135671370372276360989D+00 px(17)= 0.16259709487800222734179448321576442D+00 px(18)= 0.18982033572772041366926851284912359D+00 px(19)= 0.22087111215348614429940107012361562D+00 px(20)= 0.25632195206452177680013231303976781D+00 px(21)= 0.29683337125272468206259039405023979D+00 px(22)= 0.34316518501958180617486163242847902D+00 px(23)= 0.39618960592837583486273888758703435D+00 px(24)= 0.45690644457913117767731277056887464D+00 px(25)= 0.52646073119585672648955063711186170D+00 px(26)= 0.60616309005755762712921556869139875D+00 px(27)= 0.69751323092341496562260118366147217D+00 px(28)= 0.80222697243582393516449526286850739D+00 px(29)= 0.92226728168578278287496843309443837D+00 px(30)= 0.10598799021605760545446954338407357D+01 px(31)= 0.12176342516911872309482334694729854D+01 px(32)= 0.13984704081792695653834769855727069D+01 px(33)= 0.16057531729310064020228982054108760D+01 px(34)= 0.18433344234846220454903450952844757D+01 px(35)= 0.21156252611660201772094982169604363D+01 px(36)= 0.24276798551755632926179359953601148D+01 px(37)= 0.27852934330452205314765679671405731D+01 px(38)= 0.31951176405057028717258322130425570D+01 px(39)= 0.36647976062397870566073557102018905D+01 px(40)= 0.42031366779907243753664331178612278D+01 px(41)= 0.48202972331234718143106561639280279D+01 px(42)= 0.55280496786915488679928146699422870D+01 px(43)= 0.63400875319084531166198158934082316D+01 px(44)= 0.72724356766190935880980645516629891D+01 px(45)= 0.83439939737765991151533907320407321D+01 px(46)= 0.95772839454414406682247983833388953D+01 px(47)= 0.10999511253155353900722704602341888D+02 px(48)= 0.12644139881765944224874013113714956D+02 px(49)= 0.14553337047736742937007375682160668D+02 px(50)= 0.16781991883653111960448246164544552D+02 px(51)= 0.19404807001908978674636447631480543D+02 px(52)= 0.22530041649957455873120088574563768D+02 px(53)= 0.26329908156600549662558562174411129D+02 px(54)= 0.31123139662609753954221361691834122D+02 px(55)= 0.37704208661211514525413812039019937D+02 pw( 1)= 0.66197010017150176035001943503791612D-03 pw( 2)= 0.15473986838973462236228078334406893D-02 pw( 3)= 0.24498237063923531340555158367628164D-02 pw( 4)= 0.33776287859319922812719456819175282D-02 pw( 5)= 0.43411225775038708068974684768107364D-02 pw( 6)= 0.53518651954260805354105863317050609D-02 pw( 7)= 0.64229967432330231179415055321225939D-02 pw( 8)= 0.75696698103592431759756449888418760D-02 pw( 9)= 0.88095427367590507023412664390713554D-02 pw(10)= 0.10163325161348951569439668089332658D-01 pw(11)= 0.11655363240567140813674097334911855D-01 pw(12)= 0.13314243348515058027067949270881268D-01 pw(13)= 0.15173386635166955733192695121243376D-01 pw(14)= 0.17271608028279645041513857207256865D-01 pw(15)= 0.19653626901657341159725115198646941D-01 pw(16)= 0.22370543498465587594423534082963911D-01 pw(17)= 0.25480329057857957803698239091828550D-01 pw(18)= 0.29048405984491612079844523910580431D-01 pw(19)= 0.33148404854392620654285014862228099D-01 pw(20)= 0.37863173170688566168679168381831541D-01 pw(21)= 0.43286083546221674152033551748574709D-01 pw(22)= 0.49522660152701866580552473522264330D-01 pw(23)= 0.56692523854953065740425656620598762D-01 pw(24)= 0.64931653102898776070657891627893174D-01 pw(25)= 0.74394966967471873327666467149784361D-01 pw(26)= 0.85259253137910454276787766290602372D-01 pw(27)= 0.97726482395605256876361711073457773D-01 pw(28)= 0.11202756962445724523518796251371951D+00 pw(29)= 0.12842665975742201914453661139337216D+00 pw(30)= 0.14722603673926230968313687924515801D+00 pw(31)= 0.16877177710790063461389831494800560D+00 pw(32)= 0.19346030041623174522759333491248744D+00 pw(33)= 0.22174601068744206398277053899636196D+00 pw(34)= 0.25415028231904386989193251104458640D+00 pw(35)= 0.29127212894662705701804000206750184D+00 pw(36)= 0.33380101778748297671825708760982179D+00 pw(37)= 0.38253247505964083905642476699352139D+00 pw(38)= 0.43838740189609651989190850364739389D+00 pw(39)= 0.50243643541811971842045067743697266D+00 pw(40)= 0.57593132895181935261643585397322053D+00 pw(41)= 0.66034632680141149455034526996759720D+00 pw(42)= 0.75743410948623930877746056875550536D+00 pw(43)= 0.86930350487407763483137649785144665D+00 pw(44)= 0.99853057127864209173395623916848905D+00 pw(45)= 0.11483223403291556759761625679375804D+01 pw(46)= 0.13227664361633706905774477225292859D+01 pw(47)= 0.15272262858299299746420952422140745D+01 pw(48)= 0.17689950292216856169402049903686857D+01 pw(49)= 0.20584365667376688423615789562990280D+01 pw(50)= 0.24111135465716154769717216299933567D+01 pw(51)= 0.28521135641444982391089026540840319D+01 pw(52)= 0.34259355468040848187361378226527105D+01 pw(53)= 0.42232267265008794416077388243344182D+01 pw(54)= 0.54752904412621487070917591943555763D+01 pw(55)= 0.81175842524558588852537391429064074D+01 endif if(kn == 56) then px( 1)= 0.25316296361047986979222704481695825D-03 px( 2)= 0.13365901075979378376059799633963547D-02 px( 3)= 0.32968187867088652972746128579161298D-02 px( 4)= 0.61535889280423947494589016534393146D-02 px( 5)= 0.99356438145931069871255487366443905D-02 px( 6)= 0.14681977810167156277573501598213788D-01 px( 7)= 0.20443111678193472909091734497338465D-01 px( 8)= 0.27282717458052044439797443722558727D-01 px( 9)= 0.35279661237909244138393562138044293D-01 px(10)= 0.44530515113621224893066466054989604D-01 px(11)= 0.55152581833421451048846493819641517D-01 px(12)= 0.67287461982589797279652325494947566D-01 px(13)= 0.81105172698463510127775615113455155D-01 px(14)= 0.96808802192712951405093425956382214D-01 px(15)= 0.11463966370426778674305108921559686D+00 px(16)= 0.13488290707039924587391549901601733D+00 px(17)= 0.15787356616502069558695735577341045D+00 px(18)= 0.18400306948311470201893098688372094D+00 px(19)= 0.21372631172205091315476055948506776D+00 px(20)= 0.24756945964825417876144186941921348D+00 px(21)= 0.28613872754179262008712244069824825D+00 px(22)= 0.33013039508573925156714087895320715D+00 px(23)= 0.38034235430595768392206349401494352D+00 px(24)= 0.43768747182717257038476928803614522D+00 px(25)= 0.50320905100551354990170632643254963D+00 px(26)= 0.57809868566859133942855647933251305D+00 px(27)= 0.66371681885395609603081291900385610D+00 px(28)= 0.76161635782113158520389067408690172D+00 px(29)= 0.87356975058892174416448481275277481D+00 px(30)= 0.10015999992219932485646137689436440D+01 px(31)= 0.11480161722880751230648197166792158D+01 px(32)= 0.13154540866711925408169656894558134D+01 px(33)= 0.15069229633419957830339656064577451D+01 px(34)= 0.17258590324121035302982461790011709D+01 px(35)= 0.19761872844199233411044622815807802D+01 px(36)= 0.22623928590392104330658026022941003D+01 px(37)= 0.25896039617088162412729887555211206D+01 px(38)= 0.29636887519045083121995707405502705D+01 px(39)= 0.33913694283389338916129064504517107D+01 px(40)= 0.38803578612346352983211862453492671D+01 px(41)= 0.44395187703404766581147350250334258D+01 px(42)= 0.50790689079212912344545291525845662D+01 px(43)= 0.58108244499131239038620507188960897D+01 px(44)= 0.66485146168191270558987216454001789D+01 px(45)= 0.76081888077726672589265324613407006D+01 px(46)= 0.87087596930040374091019857045701857D+01 px(47)= 0.99727503684543062151028368853863376D+01 px(48)= 0.11427358864753300284154140246256655D+02 px(49)= 0.13106036822460464759217266858454354D+02 px(50)= 0.15050942893772414274408031537252686D+02 px(51)= 0.17316976836533264840463009058352564D+02 px(52)= 0.19978899582721245916009884455806908D+02 px(53)= 0.23145132959066649402957025145184967D+02 px(54)= 0.26988283646585129742188842153188599D+02 px(55)= 0.31828066291287360025547176837209814D+02 px(56)= 0.38461992963555384952401394913962473D+02 pw( 1)= 0.65000398579028612344523107765589882D-03 pw( 2)= 0.15191959531332206241117313092588598D-02 pw( 3)= 0.24045082453807306790230685497814259D-02 pw( 4)= 0.33138053120687689905848031561566419D-02 pw( 5)= 0.42567825727886822265204218213429885D-02 pw( 6)= 0.52442786039205566768969009014580993D-02 pw( 7)= 0.62885672143814305898041140071920990D-02 pw( 8)= 0.74037469337422375540169840316881048D-02 pw( 9)= 0.86061856387838724696966695518776445D-02 pw(10)= 0.99150131408851259539215604893253718D-02 pw(11)= 0.11352651712245621514495559004367745D-01 pw(12)= 0.12945367107597103270871461076597819D-01 pw(13)= 0.14723816350026995714384635716386299D-01 pw(14)= 0.16723567921281172025119870508991203D-01 pw(15)= 0.18985579339702223096072943965050960D-01 pw(16)= 0.21556638092713088509079450535846802D-01 pw(17)= 0.24489800737865776493594940653820355D-01 pw(18)= 0.27844892154300886517220254607831059D-01 pw(19)= 0.31689141187091977270960955143508341D-01 pw(20)= 0.36098024102012043921594821940947720D-01 pw(21)= 0.41156366531808391430233301214909888D-01 pw(22)= 0.46959728529751547723837911521797776D-01 pw(23)= 0.53616077334483042468992867566071648D-01 pw(24)= 0.61247744777900280040241146591130434D-01 pw(25)= 0.69993670734405775857440933512557351D-01 pw(26)= 0.80011946473114843210018552446024989D-01 pw(27)= 0.91482687623385083454637087474649108D-01 pw(28)= 0.10461128275712219242263696233465467D+00 pw(29)= 0.11963207950030344698937570198730592D+00 pw(30)= 0.13681258639855890430946376814155933D+00 pw(31)= 0.15645828725394505928296678986188780D+00 pw(32)= 0.17891818774495993299205732107037433D+00 pw(33)= 0.20459124493705478925339465025762632D+00 pw(34)= 0.23393387292296502681950858384393993D+00 pw(35)= 0.26746877815837016930288816174815801D+00 pw(36)= 0.30579546472966641872754674677137451D+00 pw(37)= 0.34960287592590148622876766322786034D+00 pw(38)= 0.39968482435244330897498051519252302D+00 pw(39)= 0.45695914023983362115797429164759424D+00 pw(40)= 0.52249188739719558018523893289646747D+00 pw(41)= 0.59752864128661802876559766037133258D+00 pw(42)= 0.68353583227497725169589493456556878D+00 pw(43)= 0.78225676673770165676669761907089189D+00 pw(44)= 0.89578957040518890914540096033762699D+00 pw(45)= 0.10266987265790718339050961200134187D+01 pw(46)= 0.11781795916828648269313771182072094D+01 pw(47)= 0.13543092491251640404184331203718613D+01 pw(48)= 0.15604436574176829660651085498995850D+01 pw(49)= 0.18038746446191042006169647129755746D+01 pw(50)= 0.20949760879837258079028998605170623D+01 pw(51)= 0.24493410971001376006947638889013500D+01 pw(52)= 0.28921265037563651103311910556760302D+01 pw(53)= 0.34679810059374950896183058369361721D+01 pw(54)= 0.42678969880522956032021408252168488D+01 pw(55)= 0.55241361350341697933563283440847313D+01 pw(56)= 0.81763098024027352046055737635386992D+01 endif if(kn == 57) then px( 1)= 0.24868815335455860789772463829278776D-03 px( 2)= 0.13128708050967756872359979837581267D-02 px( 3)= 0.32378911411275754242453920014506796D-02 px( 4)= 0.60424464389102377765134145508034116D-02 px( 5)= 0.97537140744139523885808398942622953D-02 px( 6)= 0.14408512776948249945597359956767419D-01 px( 7)= 0.20054465803924087173957630667856565D-01 px( 8)= 0.26751478412571506944557766303264093D-01 px( 9)= 0.34573592603908669936189665703461548D-01 px(10)= 0.43611265799596486187161513111221049D-01 px(11)= 0.53974113832253153451922084032312655D-01 px(12)= 0.65794147604388044446693612420778637D-01 px(13)= 0.79229515286929499370440341287450519D-01 px(14)= 0.94468740236461490024906772241244278D-01 px(15)= 0.11173542497728950196695294189711635D+00 px(16)= 0.13129338283356472153949413479135588D+00 px(17)= 0.15345217055234222351399145423334369D+00 px(18)= 0.17857303240016059517363555848698504D+00 px(19)= 0.20707532489301037480311227730726369D+00 px(20)= 0.23944355888568364571611377084388653D+00 px(21)= 0.27623525598764641501713800314236035D+00 px(22)= 0.31808985711331926597193028676339348D+00 px(23)= 0.36573893965362420393418300064924317D+00 px(24)= 0.42001800250816678509315665005653842D+00 px(25)= 0.48188007571772045658000477338572683D+00 px(26)= 0.55241141366947723712332135298933352D+00 px(27)= 0.63284954422789175567060868091083275D+00 px(28)= 0.72460397335389008193055638126809504D+00 px(29)= 0.82927988618893103652768340546531032D+00 px(30)= 0.94870524097232991512519332944115950D+00 px(31)= 0.10849617219948828718866932170405878D+01 px(32)= 0.12404201040143688064542721435857076D+01 px(33)= 0.14177806871234317057617629235375845D+01 px(34)= 0.16201195944991234133183611776590787D+01 px(35)= 0.18509418957597958737177594237457576D+01 px(36)= 0.21142427406807205051181553190404025D+01 px(37)= 0.24145779838341929681853920899859986D+01 px(38)= 0.27571461831926801287738694538112624D+01 px(39)= 0.31478844142641227801141212544520951D+01 px(40)= 0.35935811310102033845744816463442230D+01 px(41)= 0.41020104413877221957804467425939289D+01 px(42)= 0.46820938302391253474628239056559849D+01 px(43)= 0.53440978451440606526835982001965101D+01 px(44)= 0.60998800348958771477889866745643881D+01 px(45)= 0.69632012890426281929489833882602384D+01 px(46)= 0.79501320435284778078392913107490947D+01 px(47)= 0.90795950558462101790938546852706470D+01 px(48)= 0.10374113225206633587054123726355172D+02 px(49)= 0.11860876304821553920803819021800250D+02 px(50)= 0.13573324197835825157192895761042269D+02 px(51)= 0.15553608911071130591094968547049722D+02 px(52)= 0.17856644009398398334027651945364308D+02 px(53)= 0.20557252972621646881571546529989799D+02 px(54)= 0.23764024975150934121434317734353805D+02 px(55)= 0.27649965226105594436613117812938989D+02 px(56)= 0.32535770450738589606101398766605691D+02 px(57)= 0.39221977092927801982893352173282336D+02 pw( 1)= 0.63850406831505099738052476325581961D-03 pw( 2)= 0.14921037986204782494894229786059731D-02 pw( 3)= 0.23610114029305975624758426308210372D-02 pw( 4)= 0.32526128541318438561754430100405078D-02 pw( 5)= 0.41760397770836242676248541207424580D-02 pw( 6)= 0.51414703399848581702756105177606384D-02 pw( 7)= 0.61603891216042467763280301070012439D-02 pw( 8)= 0.72459385496994110627368996655782062D-02 pw( 9)= 0.84133204261124725154997593044037002D-02 pw(10)= 0.96802413566072434418561861828501851D-02 pw(11)= 0.11067394131957919015201993364016383D-01 pw(12)= 0.12598960733898038415484720369114255D-01 pw(13)= 0.14303116690973784728070109566032249D-01 pw(14)= 0.16212514694032192842344075317239116D-01 pw(15)= 0.18364731480288355645565506966903663D-01 pw(16)= 0.20802678116001007719911702716244623D-01 pw(17)= 0.23574997949263392825181094032890825D-01 pw(18)= 0.26736501608313518430082020410358951D-01 pw(19)= 0.30348704821972667356360038317766333D-01 pw(20)= 0.34480535573107543829081934087773551D-01 pw(21)= 0.39209262449594068155056630028607624D-01 pw(22)= 0.44621673558809258382775767008026743D-01 pw(23)= 0.50815515123079612189194336850658426D-01 pw(24)= 0.57901188015516540741960287519003280D-01 pw(25)= 0.66003700690181420273674403867109883D-01 pw(26)= 0.75264885586780504125481386653660311D-01 pw(27)= 0.85845899110248805481309245561278484D-01 pw(28)= 0.97930039537017286368934956545788095D-01 pw(29)= 0.11172593126446497910307506265827343D+00 pw(30)= 0.12747113783580932628750351291841410D+00 pw(31)= 0.14543628129357976189998302298577329D+00 pw(32)= 0.16592976340385132601117576239709225D+00 pw(33)= 0.18930320741347600799686592812399379D+00 pw(34)= 0.21595777019635163082254656264589623D+00 pw(35)= 0.24635151796681218166031807821910603D+00 pw(36)= 0.28100812005137097745126867432418044D+00 pw(37)= 0.32052720324236309080623061527301095D+00 pw(38)= 0.36559683724134186969654741198617812D+00 pw(39)= 0.41700881002095348086483260374822063D+00 pw(40)= 0.47567763253365164936264867132129384D+00 pw(41)= 0.54266463607013432598384544728159736D+00 pw(42)= 0.61920917583183104118650977432015768D+00 pw(43)= 0.70676996963437778493319526328106689D+00 pw(44)= 0.80708121914722438188398403384545040D+00 pw(45)= 0.92223080476089922545257576125601390D+00 pw(46)= 0.10547722906765838946076024117162519D+01 pw(47)= 0.12078902142342952742295563718452734D+01 pw(48)= 0.13856521611695241681852077225258712D+01 pw(49)= 0.15934078194682780100598346033527563D+01 pw(50)= 0.18384490024798631769423787694389017D+01 pw(51)= 0.21311608735825934018647767200886737D+01 pw(52)= 0.24871681932345592025950623054739285D+01 pw(53)= 0.29316978875123326489119117358318389D+01 pw(54)= 0.35095485536224900059615141531182325D+01 pw(55)= 0.43120561559297553662108510075135951D+01 pw(56)= 0.55724340409598520094151224510004002D+01 pw(57)= 0.82344141971751154156256216589492573D+01 endif if(kn == 58) then px( 1)= 0.24434033394451184831332088274972614D-03 px( 2)= 0.12898297855758084794990735012824795D-02 px( 3)= 0.31806717757901164181366233077269143D-02 px( 4)= 0.59345896357739671411939250656689172D-02 px( 5)= 0.95773007935647589740131510133326933D-02 px( 6)= 0.14143599916031750336288464659818307D-01 px( 7)= 0.19678421471099466334328004427638463D-01 px( 8)= 0.26238185206866063929609421458766724D-01 px( 9)= 0.33892482730395244265993385655932016D-01 px(10)= 0.42726147636423146495787112568669502D-01 px(11)= 0.52841746547136186264664886791106024D-01 px(12)= 0.64362519550464307152961734809637400D-01 px(13)= 0.77435783944099717432445083945677444D-01 px(14)= 0.92236796334736021064525541096205779D-01 px(15)= 0.10897304960833762497368263739776640D+00 px(16)= 0.12788897058127535161532867316020021D+00 px(17)= 0.14927098966869470910429970787632708D+00 px(18)= 0.17345298118495822795560109857844673D+00 px(19)= 0.20082212068477187733619503336787526D+00 px(20)= 0.23182526492157509727427115110610957D+00 px(21)= 0.26697601677385238610408934208835716D+00 px(22)= 0.30686267976111180750915583977482233D+00 px(23)= 0.35215732947079012938113786105805915D+00 px(24)= 0.40362623554087235036623549904310772D+00 px(25)= 0.46214186627722416843651050017300999D+00 px(26)= 0.52869670779772405928275015906498196D+00 px(27)= 0.60441913758500942132872353014906915D+00 px(28)= 0.69059161190173186977923080505129435D+00 px(29)= 0.78867145852021566336079167775472318D+00 px(30)= 0.90031461037842010940804732183197484D+00 px(31)= 0.10274026720013124888351576363117054D+01 px(32)= 0.11720737797358867139870870772361403D+01 px(33)= 0.13367578014779413237552856365102921D+01 px(34)= 0.15242165260123579138727083350791305D+01 px(35)= 0.17375896232753198202855353912673167D+01 px(36)= 0.19804473251817493601350778629165516D+01 px(37)= 0.22568509975250307614430520806868566D+01 px(38)= 0.25714230695306034625372310347575688D+01 px(39)= 0.29294281925088078526353597436284922D+01 px(40)= 0.33368680628505624786084197643705525D+01 px(41)= 0.38005931431891197468681483744664603D+01 px(42)= 0.43284356654318541562597981524559705D+01 px(43)= 0.49293699827199698643746537542247355D+01 px(44)= 0.56137088447382837752405108085311518D+01 px(45)= 0.63933479763797142778167198658680473D+01 px(46)= 0.72820772388702724076103924229296585D+01 px(47)= 0.82959860217191960273479806666773572D+01 px(48)= 0.94540058246887833757920831704609262D+01 px(49)= 0.10778658868884060967669218732823142D+02 px(50)= 0.12297127123681394967235226888868496D+02 px(51)= 0.14042840296906789602475373898648457D+02 px(52)= 0.16057946341424185599637733181299734D+02 px(53)= 0.18397376144609008660129440553886667D+02 px(54)= 0.21136019829441359432294268771943368D+02 px(55)= 0.24382637830465314053970048093781607D+02 px(56)= 0.28310635883229105824662724848457888D+02 px(57)= 0.33241688156491882652244516947157465D+02 px(58)= 0.39979324854730350560380760310991567D+02 pw( 1)= 0.62733109048409588703595816867276199D-03 pw( 2)= 0.14657936036557848053358560746138226D-02 pw( 3)= 0.23188039412803108240913072658971970D-02 pw( 4)= 0.31933033503497732665912080929284740D-02 pw( 5)= 0.40979006451946182384357721499095629D-02 pw( 6)= 0.50421643688026695837303498584333168D-02 pw( 7)= 0.60368540232012649771110859344923619D-02 pw( 8)= 0.70942376382161779284891095459836907D-02 pw( 9)= 0.82284548942576416691892667668446138D-02 pw(10)= 0.94559203825706345816982076964964040D-02 pw(11)= 0.10795760712764688238988523701079555D-01 pw(12)= 0.12270273749594030379848145803872545D-01 pw(13)= 0.13905392767905254997074541953428596D-01 pw(14)= 0.15731135789435791324224040917880572D-01 pw(15)= 0.17782024053941809054144110879593548D-01 pw(16)= 0.20097465728382493095345225347477278D-01 pw(17)= 0.22722120795621834323838288686748639D-01 pw(18)= 0.25706285556264310174964040630928441D-01 pw(19)= 0.29106352315788903005352971189456581D-01 pw(20)= 0.32985404610440883148326461811537831D-01 pw(21)= 0.37413999049710482757623335110546207D-01 pw(22)= 0.42471166374810272031277917315265662D-01 pw(23)= 0.48245645122530704885901911499992297D-01 pw(24)= 0.54837348649234653699497897577026759D-01 pw(25)= 0.62359063229977042722185054531332040D-01 pw(26)= 0.70938380290334218998361325437647613D-01 pw(27)= 0.80719876243549163356586986213036934D-01 pw(28)= 0.91867565718926819665093909060870324D-01 pw(29)= 0.10456766632576442199326583277715739D+00 pw(30)= 0.11903172509910440103985964305294291D+00 pw(31)= 0.13550016907993941758980848856857065D+00 pw(32)= 0.15424635639536902570179058036488656D+00 pw(33)= 0.17558122145590420153365262455970893D+00 pw(34)= 0.19985863067967063227542616526431877D+00 pw(35)= 0.22748159641691842637396351126311924D+00 pw(36)= 0.25890954059680923306019616384762021D+00 pw(37)= 0.29466686202428234212246962384893466D+00 pw(38)= 0.33535315105334115324523894344163479D+00 pw(39)= 0.38165552584862205474730474843490408D+00 pw(40)= 0.43436375602075320325783351993460999D+00 pw(41)= 0.49438912403001643077208212506747590D+00 pw(42)= 0.56278840340808053436660241948913705D+00 pw(43)= 0.64079498868817746739885701660482042D+00 pw(44)= 0.72986023375748618090030528388862540D+00 pw(45)= 0.83170968157393847753518524949795654D+00 pw(46)= 0.94842152201009860199494152865552426D+00 pw(47)= 0.10825390752513919957077425880259437D+01 pw(48)= 0.12372368612987946539691608858506276D+01 pw(49)= 0.14165738915071239610049524678978730D+01 pw(50)= 0.16258946038408501735019290717589660D+01 pw(51)= 0.18724918616166796018089411475069718D+01 pw(52)= 0.21667631278657422335640585222239716D+01 pw(53)= 0.25243656135025940850141001255242091D+01 pw(54)= 0.29705966338517197699939016107637128D+01 pw(55)= 0.35504038802739003258026682341550974D+01 pw(56)= 0.43554634619204172726228503521716960D+01 pw(57)= 0.56199288682781632030749398177962085D+01 pw(58)= 0.82915991164603216241594990786246181D+01 endif if(kn == 59) then px( 1)= 0.24017044279779292814629839617243450D-03 px( 2)= 0.12677357311318245204340430050679257D-02 px( 3)= 0.31258222629100185940076720172210997D-02 px( 4)= 0.58312499497336295459920293987796347D-02 px( 5)= 0.94083841957770971773603088185375410D-02 px( 6)= 0.13890148671899779318807930205580027D-01 px( 7)= 0.19318997801708323654202530335822085D-01 px( 8)= 0.25748144263471581820366574897844328D-01 px( 9)= 0.33243095406506599413902998194831696D-01 px(10)= 0.41883537206821979634762367168491752D-01 px(11)= 0.51765600230040784734413248495245234D-01 px(12)= 0.63004534953194280528857501029401263D-01 px(13)= 0.75737811688489614503254126944665394D-01 px(14)= 0.90128644081599828866050645306435530D-01 px(15)= 0.10636991817245456656640674998882425D+00 px(16)= 0.12468849734796975917708256298381635D+00 px(17)= 0.14534987449428730815870543082646967D+00 px(18)= 0.16866316194781867947963273417414352D+00 px(19)= 0.19498644807014926777480289949553731D+00 px(20)= 0.22473260025151679743882657221256944D+00 px(21)= 0.25837564665252656619516749971741362D+00 px(22)= 0.29645791158221640514428954276611043D+00 px(23)= 0.33959810551825596456611237045554791D+00 px(24)= 0.38850058094912455808801515111809716D+00 px(25)= 0.44396596557949377138507728624091020D+00 px(26)= 0.50690338304849533824426898328468191D+00 px(27)= 0.57834447492359249583873987633512907D+00 px(28)= 0.65945945037149605268093152551109157D+00 px(29)= 0.75157541311753698549281538653947915D+00 px(30)= 0.85619724923675556880411715666490139D+00 px(31)= 0.97503140385009140556694003085244755D+00 px(32)= 0.11100129303358947930559321811557219D+01 px(33)= 0.12633362636366230834317390982154572D+01 px(34)= 0.14374902524376435821063430688457459D+01 px(35)= 0.16352980880451859683554892839580029D+01 px(36)= 0.18599628978969427131632789868222316D+01 px(37)= 0.21151199396574527695286927569279424D+01 px(38)= 0.24048965537486799801854034104807364D+01 px(39)= 0.27339813311614543030519151016136162D+01 px(40)= 0.31077043634013766751037593199231006D+01 px(41)= 0.35321310127538594381872851430342547D+01 px(42)= 0.40141724497033117837380156117688880D+01 px(43)= 0.45617173671065324231220714157123560D+01 px(44)= 0.51837909802502262421170872012101186D+01 px(45)= 0.58907499495757681122761284245660513D+01 px(46)= 0.66945256944244027786731357744463874D+01 px(47)= 0.76089345000234897625689957165319158D+01 px(48)= 0.86500822381865882984046085645261005D+01 px(49)= 0.98369069052844445818188741380057179D+01 px(50)= 0.11191928172141132463081500916511436D+02 px(51)= 0.12742318869317979750127012420299866D+02 px(52)= 0.14521497812382557030759980660881216D+02 px(53)= 0.16571609002403235432729979108495388D+02 px(54)= 0.18947601696583022289134197021834890D+02 px(55)= 0.21724434819141199485567406823338980D+02 px(56)= 0.25011043569653595241704228425344735D+02 px(57)= 0.28981239539754668238717062448027987D+02 px(58)= 0.33957682861442574052880069059391550D+02 px(59)= 0.40746915059614258028591599305878563D+02 pw( 1)= 0.61661580843002818474199774713820435D-03 pw( 2)= 0.14405704070514471179034636856714158D-02 pw( 3)= 0.22783669060606481294489644369246025D-02 pw( 4)= 0.31365358110962922351769249715961996D-02 pw( 5)= 0.40232040175153947001508790877931979D-02 pw( 6)= 0.49473803193663214737587320055863858D-02 pw( 7)= 0.59191612038299517714653169073172258D-02 pw( 8)= 0.69500182956008661963671339567494311D-02 pw( 9)= 0.80531272876872073780988243944927837D-02 pw(10)= 0.92437335233207542919233267694815444D-02 pw(11)= 0.10539549268603537847804050413706850D-01 pw(12)= 0.11961173126551657822377551429583253D-01 pw(13)= 0.13532517058206043238763114996607351D-01 pw(14)= 0.15281223576152454708908655408040014D-01 pw(15)= 0.17239057603729693052163344051819092D-01 pw(16)= 0.19442266458961476989325558184455495D-01 pw(17)= 0.21931917469546401944382556564398834D-01 pw(18)= 0.24754242433746641427431268228835038D-01 pw(19)= 0.27961035103797151420897993567315053D-01 pw(20)= 0.31610155514745908523448651363558848D-01 pw(21)= 0.35766190345276654301560678957468317D-01 pw(22)= 0.40501304167252803397704165063681030D-01 pw(23)= 0.45896299064297235092911388363815978D-01 pw(24)= 0.52041886574768681501627601462919698D-01 pw(25)= 0.59040170127350183777203679746281117D-01 pw(26)= 0.67006338167425270345951219198202241D-01 pw(27)= 0.76070575665505304542628473598135760D-01 pw(28)= 0.86380211831507007368019890251542642D-01 pw(29)= 0.98102132636666032695755579145966437D-01 pw(30)= 0.11142549737101106673605436812360518D+00 pw(31)= 0.12656480912918894407887994146661412D+00 pw(32)= 0.14376340063800550321586640229070301D+00 pw(33)= 0.16329741041010875411766070944591531D+00 pw(34)= 0.18548034139204283612129505343431894D+00 pw(35)= 0.21066831722133520869183148142544999D+00 pw(36)= 0.23926618297652114852711313447455029D+00 pw(37)= 0.27173464220061857023595757633130234D+00 pw(38)= 0.30859868602838502541227655874922030D+00 pw(39)= 0.35045766213824028933896241045941680D+00 pw(40)= 0.39799746405898883695366965337609207D+00 pw(41)= 0.45200551538659797325171404962194440D+00 pw(42)= 0.51338951072222608042425293298227461D+00 pw(43)= 0.58320130681121704145811176462102830D+00 pw(44)= 0.66266801682533587367291708503855157D+00 pw(45)= 0.75323338727944523148159051268884834D+00 pw(46)= 0.85661417022141803759749168951905898D+00 pw(47)= 0.97487886818484736512715176832767718D+00 pw(48)= 0.11105607080548591676445817081025167D+01 pw(49)= 0.12668244926674778382406916781590943D+01 pw(50)= 0.14477211050240886139248358867709201D+01 pw(51)= 0.16585903209293941982874152551002654D+01 pw(52)= 0.19067267819120553533052269878705101D+01 pw(53)= 0.22025411213234530205031685493395576D+01 pw(54)= 0.25617240229328119031730477599209231D+01 pw(55)= 0.30096444005352699081587070335073080D+01 pw(56)= 0.35914005587611010508966597641663763D+01 pw(57)= 0.43990110029151586972435889347654638D+01 pw(58)= 0.56675740145564914236518411943414860D+01 pw(59)= 0.83489730609712306624049954354151761D+01 endif end subroutine wts500 end MODULE WTS500_MOD ectrans-1.8.0/src/trans/common/external/0000775000175000017500000000000015174631767020414 5ustar alastairalastairectrans-1.8.0/src/trans/common/external/ini_spec_dist.F900000775000175000017500000000666715174631767023532 0ustar alastairalastair! (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 INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS,KPTRMS,KALLMS) !**** *INI_SPEC_DIST* - Initialize spectral wave distribution ! Purpose. ! -------- ! Initialize arrays controlling spectral wave distribution !** Interface. ! ---------- ! CALL INI_SPEC_DIST(...) ! Explicit arguments : ! -------------------- ! KSMAX - spectral truncation required ! KTMAX - Overtruncation for KSMAX (input) ! KPRTRW - Number of processors in A-direction (input) ! KMYSETW - A-set for present processor (input) ! KASM0 - Offsets for spectral waves (output) ! KSPOLEGL - Local version of NSPOLEG (output) ! KPROCM - Where a certain spectral wave belongs (output) ! KUMPP - Number of spectral waves on this PE (output) ! KSPEC - Local version on NSPEC (output) ! KSPEC2 - Local version on NSPEC2 (output) ! KSPEC2MX - Maximum KSPEC2 across PEs (output) ! KPOSSP - Global spectral fields partitioning (output) ! KMYMS - This PEs spectral zonal wavenumbers (output) ! KPTRMS - Pointer to the first wave number of a given a-set (output) ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order (output) ! Implicit arguments : NONE ! -------------------- ! Method. ! ------- ! See documentation ! Externals. SUWAVEDI ! ---------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY: JPIM !ifndef INTERFACE USE SUWAVEDI_MOD, ONLY: SUWAVEDI USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KTMAX INTEGER(KIND=JPIM),INTENT(IN) :: KPRTRW INTEGER(KIND=JPIM),INTENT(IN) :: KMYSETW INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC2 INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC2MX INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPOLEGL INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KASM0(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPROCM(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KUMPP(KPRTRW) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPOSSP(KPRTRW+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMYMS(KSMAX+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPTRMS(KPRTRW) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KALLMS(KSMAX+1) !ifndef INTERFACE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('INI_SPEC_DIST',0,ZHOOK_HANDLE) CALL SUWAVEDI(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS,KPTRMS,KALLMS) IF (LHOOK) CALL DR_HOOK('INI_SPEC_DIST',1,ZHOOK_HANDLE) !endif INTERFACE END SUBROUTINE INI_SPEC_DIST ectrans-1.8.0/src/trans/common/external/get_current.F900000664000175000017500000000307615174631767023223 0ustar alastairalastair! (C) Copyright 2012- Meteo-France. ! (C) Copyright 2012- ECMWF. ! ! 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 GET_CURRENT(KRESOL,LDLAM) !**** *GET_CURRENT* - Extract current information from the transform package ! Purpose. ! -------- ! Interface routine for extracting current information from the T.P. !** Interface. ! ---------- ! CALL GET_CURRENT(...) ! Explicit arguments : (all optional) ! -------------------- ! KRESOL - Current resolution ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Ryad El Khatib *Meteo-France* ! Modifications. ! -------------- ! Original : 24-Aug-2012 ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM !ifndef INTERFACE USE TPM_GEN, ONLY : NCUR_RESOL USE TPM_GEOMETRY, ONLY : G !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: KRESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM !ifndef INTERFACE ! Get current resolution IF (PRESENT(KRESOL)) KRESOL= NCUR_RESOL IF (PRESENT(LDLAM)) LDLAM = G%LAM !endif INTERFACE END SUBROUTINE GET_CURRENT ectrans-1.8.0/src/trans/common/external/setup_trans0.F900000664000175000017500000001477415174631767023340 0ustar alastairalastair! (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 SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& & KPRGPNS,KPRGPEW,KPRTRW,KCOMBFLEN,& & LDMPOFF,LDSYNC_TRANS,KTRANS_SYNC_LEVEL,& & LDEQ_REGIONS,K_REGIONS_NS,K_REGIONS_EW,K_REGIONS,& & PRAD,LDALLOPERM,KOPT_MEMORY_TR) !**** *SETUP_TRANS0* - General setup routine for transform package ! Purpose. ! -------- ! Resolution independent part of setup of transform package ! Has to be called BEFORE SETUP_TRANS !** Interface. ! ---------- ! CALL SETUP_TRANS0(...) ! Explicit arguments : All arguments are optional, [..] default value ! ------------------- ! KOUT - Unit number for listing output [6] ! KERR - Unit number for error messages [0] ! KPRINTLEV - level of output to KOUT, 0->no output,1->normal,2->debug [0] ! KMAX_RESOL - maximum number of different resolutions for this run [1] ! KPRGPNS - splitting level in N-S direction in grid-point space [1] ! KPRGPEW - splitting level in E-W direction in grid-point space [1] ! KPRTRW - splitting level in wave direction in spectral space [1] ! KCOMBFLEN - Size of communication buffer [1800000 (*8bytes) ] (deprecated) ! LDMPOFF - switch off message passing [false] ! LDSYNC_TRANS - switch to activate barriers in trmtol trltom [false] ! KTRANS_SYNC_LEVEL - use of synchronization/blocking [0] ! LDEQ_REGIONS - true if new eq_regions partitioning [false] ! K_REGIONS - Number of regions (1D or 2D partitioning) ! K_REGIONS_NS - Maximum number of NS partitions ! K_REGIONS_EW - Maximum number of EW partitions ! PRAD - Radius of the planet ! LDALLOPERM - Allocate certain arrays permanently ! KOPT_MEMORY_TR - memory strategy (stack vs heap) in gripoint transpositions ! The total number of (MPI)-processors has to be equal to KPRGPNS*KPRGPEW ! Method. ! ------- ! Externals. SUMP_TRANS0 - initial setup routine ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! R. El Khatib 03-01-24 LDMPOFF ! G. Mozdzynski 2006-09-13 LDEQ_REGIONS ! N. Wedi 2009-11-30 add radius ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM ,JPRD !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, LMPOFF, LSYNC_TRANS, NTRANS_SYNC_LEVEL, MSETUP0, & & NMAX_RESOL, NPRINTLEV, NPROMATR, LALLOPERM, NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : LEQ_REGIONS, NPRGPEW, NPRGPNS, NPRTRW USE TPM_CONSTANTS ,ONLY : RA USE SUMP_TRANS0_MOD ,ONLY : SUMP_TRANS0 USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE EQ_REGIONS_MOD ,ONLY : N_REGIONS, N_REGIONS_EW, N_REGIONS_NS USE ECTRANS_VERSION_MOD ,ONLY : ECTRANS_VERSION_STR, ECTRANS_GIT_SHA1 !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KPRGPNS,KPRGPEW,KPRTRW,KCOMBFLEN LOGICAL ,OPTIONAL,INTENT(IN) :: LDMPOFF LOGICAL ,OPTIONAL,INTENT(IN) :: LDSYNC_TRANS INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KTRANS_SYNC_LEVEL LOGICAL ,OPTIONAL,INTENT(IN) :: LDEQ_REGIONS LOGICAL ,OPTIONAL,INTENT(IN) :: LDALLOPERM REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PRAD INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KOPT_MEMORY_TR INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS(:) INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_NS INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_EW !ifndef INTERFACE LOGICAL :: LLP1,LLP2 ! ------------------------------------------------------------------ IF(MSETUP0 /= 0) THEN ! SUMP_TRANS0 should be run only once (arrays allocation) RETURN ENDIF ! Default values NOUT = 6 NERR = 0 NPRINTLEV = 0 NMAX_RESOL = 1 NPRGPNS = 1 NPRGPEW = 1 NPRTRW = 1 N_REGIONS_NS=1 N_REGIONS_EW=1 NPROMATR = 0 LMPOFF = .FALSE. LSYNC_TRANS=.FALSE. NTRANS_SYNC_LEVEL=0 LEQ_REGIONS=.FALSE. RA=6371229._JPRD LALLOPERM=.FALSE. NSTACK_MEMORY_TR=0 ! Optional arguments IF(PRESENT(KOUT)) THEN NOUT = KOUT ENDIF IF(PRESENT(KERR)) THEN NERR = KERR ENDIF IF(PRESENT(KPRINTLEV)) THEN NPRINTLEV = KPRINTLEV ENDIF ! Print ecTrans version information WRITE(NOUT,'(A)') WRITE(NOUT,'(A)') "ecTrans at version: " // ECTRANS_VERSION_STR() WRITE(NOUT,'(A)') "commit: " // ECTRANS_GIT_SHA1() WRITE(NOUT,'(A)') LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SETUP_TRANS0 ===' IF(PRESENT(KMAX_RESOL))THEN NMAX_RESOL = KMAX_RESOL ENDIF IF(PRESENT(KPROMATR))THEN IF(MOD(KPROMATR,2) /= 0) THEN CALL ABORT_TRANS('SETUP_TRANS0: KPROMATR HAS TO BE MULTIPLE OF 2') ENDIF NPROMATR = KPROMATR ENDIF IF(PRESENT(KPRGPNS)) THEN NPRGPNS = KPRGPNS ENDIF IF(PRESENT(KPRGPEW)) THEN NPRGPEW = KPRGPEW ENDIF IF(PRESENT(KPRTRW)) THEN NPRTRW = KPRTRW ENDIF IF(PRESENT(KCOMBFLEN)) THEN WRITE(NOUT,'(A)') WRITE(NOUT,'(A)') '*** WARNING ***' WRITE(NOUT,'(A)') 'KCOMBFLEN argument passed to SETUP_TRANS0 is deprecated' WRITE(NOUT,'(A)') ENDIF IF(PRESENT(LDMPOFF)) THEN LMPOFF = LDMPOFF ENDIF IF(PRESENT(LDSYNC_TRANS)) THEN LSYNC_TRANS = LDSYNC_TRANS ENDIF IF(PRESENT(KTRANS_SYNC_LEVEL)) THEN NTRANS_SYNC_LEVEL = KTRANS_SYNC_LEVEL ENDIF IF(PRESENT(LDEQ_REGIONS)) THEN LEQ_REGIONS = LDEQ_REGIONS ENDIF IF(PRESENT(KOPT_MEMORY_TR))THEN NSTACK_MEMORY_TR = KOPT_MEMORY_TR ENDIF ! Initial setup CALL SUMP_TRANS0 IF(PRESENT(K_REGIONS_NS)) THEN K_REGIONS_NS = N_REGIONS_NS ENDIF IF(PRESENT(K_REGIONS_EW)) THEN K_REGIONS_EW = N_REGIONS_EW ENDIF IF(PRESENT(K_REGIONS)) THEN IF(UBOUND(K_REGIONS,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('SETUP_TRANS0: K_REGIONS TOO SMALL') ELSE K_REGIONS(1:N_REGIONS_NS)=N_REGIONS(1:N_REGIONS_NS) ENDIF ENDIF IF(PRESENT(PRAD)) THEN RA=PRAD ENDIF IF(PRESENT(LDALLOPERM)) THEN LALLOPERM=LDALLOPERM ENDIF ! Setup level 0 complete MSETUP0 = 1 ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE SETUP_TRANS0 ectrans-1.8.0/src/trans/common/sharedmem/0000775000175000017500000000000015174631767020537 5ustar alastairalastairectrans-1.8.0/src/trans/common/sharedmem/sharedmem_mod.F900000664000175000017500000002313715174631767023631 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! ! 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. ! MODULE SHAREDMEM_MOD ! Routines to allow use of shared memery segments in Fortran ! Willem Deconinck and Mats Hamrud *ECMWF* ! Original : July 2015 USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT, C_NULL_PTR,C_SIZE_T #ifdef __NEC__ #define C_SIZEOF(x) INT(KIND(x),C_SIZE_T) #endif IMPLICIT NONE PRIVATE PUBLIC :: SHAREDMEM PUBLIC :: SHAREDMEM_ALLOCATE PUBLIC :: SHAREDMEM_MALLOC_BYTES PUBLIC :: SHAREDMEM_CREATE PUBLIC :: SHAREDMEM_ASSOCIATE PUBLIC :: SHAREDMEM_ADVANCE PUBLIC :: SHAREDMEM_DELETE TYPE, BIND(C) :: SHAREDMEM ! Memory buffer TYPE(C_PTR), PRIVATE :: BEGIN=C_NULL_PTR INTEGER(C_SIZE_T), PRIVATE :: SIZE=0 ! IN BYTES TYPE(C_PTR), PRIVATE :: CPTR=C_NULL_PTR INTEGER(C_SIZE_T), PRIVATE :: OFFSET=0 ! IN BYTES END TYPE SHAREDMEM INTERFACE SHAREDMEM_ASSOCIATE ! Associate fortran scalars/arrays with memory segment MODULE PROCEDURE SHAREDMEM_ASSOCIATE0_INT32 MODULE PROCEDURE SHAREDMEM_ASSOCIATE0_REAL32 MODULE PROCEDURE SHAREDMEM_ASSOCIATE0_REAL64 MODULE PROCEDURE SHAREDMEM_ASSOCIATE1_INT32 MODULE PROCEDURE SHAREDMEM_ASSOCIATE1_REAL32 MODULE PROCEDURE SHAREDMEM_ASSOCIATE1_REAL64 MODULE PROCEDURE SHAREDMEM_ASSOCIATE2_INT32 MODULE PROCEDURE SHAREDMEM_ASSOCIATE2_REAL32 MODULE PROCEDURE SHAREDMEM_ASSOCIATE2_REAL64 END INTERFACE INTERFACE ! EXTERNAL C FUNCTIONS USED IN THIS MODULE ! ---------------------------------------- SUBROUTINE SHAREDMEM_ADVANCE_BYTES(CPTR,BYTES) BIND(C) USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_SIZE_T TYPE(C_PTR) :: CPTR INTEGER(C_SIZE_T), VALUE :: BYTES END SUBROUTINE SHAREDMEM_ADVANCE_BYTES SUBROUTINE SHAREDMEM_MALLOC_BYTES(PTR,BYTES) BIND(C) USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_SIZE_T TYPE(C_PTR) :: PTR INTEGER(C_SIZE_T), VALUE :: BYTES END SUBROUTINE SHAREDMEM_MALLOC_BYTES SUBROUTINE SHAREDMEM_FREE(PTR) BIND(C) USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR TYPE(C_PTR), INTENT(IN) :: PTR END SUBROUTINE SHAREDMEM_FREE END INTERFACE CONTAINS !========================================================================= SUBROUTINE SHAREDMEM_CREATE(HANDLE,CPTR,BYTES) ! Create memory buffer object from c pointer USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_SIZE_T, C_F_POINTER TYPE(SHAREDMEM), INTENT(OUT) :: HANDLE TYPE(C_PTR) , INTENT(IN) :: CPTR INTEGER(C_SIZE_T), INTENT(IN) :: BYTES !------------------------------------------------------------------------ HANDLE%BEGIN = CPTR HANDLE%SIZE = BYTES HANDLE%CPTR = HANDLE%BEGIN HANDLE%OFFSET = 0 END SUBROUTINE SHAREDMEM_CREATE !========================================================================= SUBROUTINE SHAREDMEM_ALLOCATE(HANDLE,BYTES) ! Create memory buffer object from Fortran USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_SIZE_T TYPE(SHAREDMEM), INTENT(OUT) :: HANDLE INTEGER(C_SIZE_T), INTENT(IN) :: BYTES INTEGER(C_SIZE_T) :: SIZE !------------------------------------------------------------------------ SIZE = BYTES CALL SHAREDMEM_MALLOC_BYTES(HANDLE%BEGIN,SIZE) HANDLE%SIZE = BYTES HANDLE%CPTR = HANDLE%BEGIN HANDLE%OFFSET = 0 END SUBROUTINE SHAREDMEM_ALLOCATE !========================================================================= SUBROUTINE SHAREDMEM_DELETE(HANDLE) ! Free memory buffer TYPE(SHAREDMEM), INTENT(OUT) :: HANDLE CALL SHAREDMEM_FREE(HANDLE%BEGIN) END SUBROUTINE SHAREDMEM_DELETE !========================================================================= ! PRIVATE SUBROUTINES ! ------------------- SUBROUTINE SHAREDMEM_ASSOCIATE0_INT32(HANDLE,VALUE,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(OUT) :: VALUE LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE INTEGER(C_INT), POINTER :: FPTR(:) INTEGER(C_INT) :: K CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/1/) ) VALUE = FPTR(1) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,C_SIZEOF(K)) HANDLE%OFFSET = HANDLE%OFFSET+C_SIZEOF(K) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE0_INT32 SUBROUTINE SHAREDMEM_ASSOCIATE0_REAL32(HANDLE,VALUE,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE REAL(C_FLOAT), INTENT(OUT) :: VALUE LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE REAL(C_FLOAT), POINTER :: FPTR(:) REAL(C_FLOAT) :: R CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/1/) ) VALUE = FPTR(1) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,C_SIZEOF(R)) HANDLE%OFFSET = HANDLE%OFFSET+C_SIZEOF(R) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE0_REAL32 SUBROUTINE SHAREDMEM_ASSOCIATE0_REAL64(HANDLE,VALUE,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE REAL(C_DOUBLE), INTENT(OUT) :: VALUE LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE REAL(C_DOUBLE), POINTER :: FPTR(:) REAL(C_DOUBLE) :: R CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/1/) ) VALUE = FPTR(1) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,C_SIZEOF(R)) HANDLE%OFFSET = HANDLE%OFFSET+C_SIZEOF(R) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE0_REAL64 SUBROUTINE SHAREDMEM_ASSOCIATE1_INT32(HANDLE,SIZE,FPTR,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(IN) :: SIZE INTEGER(KIND=C_INT), POINTER, INTENT(INOUT) :: FPTR(:) LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE INTEGER(C_INT) :: K CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/SIZE/) ) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,SIZE*C_SIZEOF(K)) HANDLE%OFFSET = HANDLE%OFFSET+SIZE*C_SIZEOF(K) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE1_INT32 SUBROUTINE SHAREDMEM_ASSOCIATE1_REAL32(HANDLE,SIZE,FPTR,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(IN) :: SIZE REAL(C_FLOAT), POINTER, INTENT(INOUT) :: FPTR(:) LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE REAL(C_FLOAT) :: R CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/SIZE/) ) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,SIZE*C_SIZEOF(R)) HANDLE%OFFSET = HANDLE%OFFSET+SIZE*C_SIZEOF(R) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE1_REAL32 SUBROUTINE SHAREDMEM_ASSOCIATE1_REAL64(HANDLE,SIZE,FPTR,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(IN) :: SIZE REAL(C_DOUBLE), POINTER, INTENT(INOUT) :: FPTR(:) LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE REAL(C_DOUBLE) :: R CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/SIZE/) ) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,SIZE*C_SIZEOF(R)) HANDLE%OFFSET = HANDLE%OFFSET+SIZE*C_SIZEOF(R) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE1_REAL64 SUBROUTINE SHAREDMEM_ASSOCIATE2_INT32(HANDLE,DIM1,DIM2,FPTR,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(IN) :: DIM1,DIM2 INTEGER(C_INT), POINTER, INTENT(INOUT) :: FPTR(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE INTEGER(C_INT) :: K CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/DIM1,DIM2/) ) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,DIM1*DIM2*C_SIZEOF(K)) HANDLE%OFFSET = HANDLE%OFFSET+DIM1*DIM2*C_SIZEOF(K) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE2_INT32 SUBROUTINE SHAREDMEM_ASSOCIATE2_REAL32(HANDLE,DIM1,DIM2,FPTR,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(IN) :: DIM1,DIM2 REAL(C_FLOAT), POINTER, INTENT(INOUT) :: FPTR(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE REAL(C_FLOAT) :: R CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/DIM1,DIM2/) ) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,DIM1*DIM2*C_SIZEOF(R)) HANDLE%OFFSET = HANDLE%OFFSET+DIM1*DIM2*C_SIZEOF(R) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE2_REAL32 SUBROUTINE SHAREDMEM_ASSOCIATE2_REAL64(HANDLE,DIM1,DIM2,FPTR,ADVANCE) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(IN) :: DIM1,DIM2 REAL(C_DOUBLE), POINTER, INTENT(INOUT) :: FPTR(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: ADVANCE REAL(C_DOUBLE) :: R CALL C_F_POINTER ( HANDLE%CPTR , FPTR , (/DIM1,DIM2/) ) IF( PRESENT(ADVANCE) ) THEN IF( ADVANCE ) THEN CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,DIM1*DIM2*C_SIZEOF(R)) HANDLE%OFFSET = HANDLE%OFFSET+DIM1*DIM2*C_SIZEOF(R) ENDIF ENDIF END SUBROUTINE SHAREDMEM_ASSOCIATE2_REAL64 SUBROUTINE SHAREDMEM_ADVANCE(HANDLE,BYTES) USE, INTRINSIC :: ISO_C_BINDING TYPE(SHAREDMEM), INTENT(INOUT) :: HANDLE INTEGER(C_INT), INTENT(IN) :: BYTES INTEGER(C_SIZE_T) :: SIZE SIZE = BYTES CALL SHAREDMEM_ADVANCE_BYTES(HANDLE%CPTR,SIZE) HANDLE%OFFSET = HANDLE%OFFSET+BYTES END SUBROUTINE SHAREDMEM_ADVANCE !============================================================================ END MODULE SHAREDMEM_MOD ectrans-1.8.0/src/trans/common/sharedmem/sharedmem.c0000664000175000017500000000123615174631767022652 0ustar alastairalastair/* * (C) Copyright 2015- ECMWF. * * 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. */ #include void sharedmem_malloc_bytes (void** ptr, size_t bytes) { *ptr = malloc(bytes); } void sharedmem_free(void** ptr) { free(*ptr); } void sharedmem_advance_bytes (void** ptr, size_t bytes) { char** char_ptr = (char**)ptr; *char_ptr += bytes; } ectrans-1.8.0/src/trans/common/CMakeLists.txt0000664000175000017500000000544115174631767021336 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. # Preprocess module file containing version information configure_file( internal/ectrans_version_mod.F90.in internal/ectrans_version_mod.F90 ) ## Sources which are precision independent can go into a common library list( APPEND ectrans_common_src sharedmem/sharedmem_mod.F90 sharedmem/sharedmem.c internal/ectrans_blas_mod.F90 internal/abort_trans_mod.F90 internal/cpledn_mod.F90 internal/field_split_mod.F90 internal/gawl_mod.F90 internal/interpol_decomp_mod.F90 internal/sugaw_mod.F90 internal/supol_mod.F90 internal/supolf_mod.F90 internal/tpm_constants.F90 internal/tpm_ctl.F90 internal/tpm_dim.F90 internal/tpm_fields.F90 internal/tpm_gen.F90 internal/tpm_geometry.F90 internal/tpm_pol.F90 internal/tpm_distr.F90 internal/pe2set_mod.F90 internal/set2pe_mod.F90 internal/eq_regions_mod.F90 internal/pre_suleg_mod.F90 internal/setup_dims_mod.F90 internal/setup_geom_mod.F90 internal/shuffle_mod.F90 internal/sump_trans0_mod.F90 internal/sustaonl_mod.F90 internal/sumplat_mod.F90 internal/sumplatb_mod.F90 internal/sumplatbeq_mod.F90 internal/sumplatf_mod.F90 internal/sutrle_mod.F90 internal/mysendset_mod.F90 internal/myrecvset_mod.F90 internal/suwavedi_mod.F90 internal/sump_trans_preleg_mod.F90 internal/wts500_mod.F90 external/get_current.F90 external/setup_trans0.F90 external/ini_spec_dist.F90 ${CMAKE_CURRENT_BINARY_DIR}/internal/ectrans_version_mod.F90 ) list( APPEND ectrans_common_includes ectrans/get_current.h ectrans/setup_trans0.h ectrans/ini_spec_dist.h ) ecbuild_add_library( TARGET ectrans_common LINKER_LANGUAGE Fortran SOURCES ${ectrans_common_src} PUBLIC_LIBS fiat PRIVATE_LIBS ${LAPACK_LIBRARIES} PUBLIC_INCLUDES $ $ $ $ ) ecbuild_target_fortran_module_directory( TARGET ectrans_common MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/ectrans INSTALL_MODULE_DIRECTORY module/ectrans ) if( HAVE_OMP ) ecbuild_debug("target_link_libraries( ectrans_common PRIVATE OpenMP::OpenMP_Fortran )") target_link_libraries( ectrans_common PRIVATE OpenMP::OpenMP_Fortran ) endif() set( ectrans_common_includes ${ectrans_common_includes} PARENT_SCOPE ) ectrans-1.8.0/src/trans/sedrenames.txt0000664000175000017500000001636715174631767020206 0ustar alastairalastairs/ASRE1_MOD/ASRE1_MOD_VARIANTDESIGNATOR/g s/ASRE1AD_MOD/ASRE1AD_MOD_VARIANTDESIGNATOR/g s/ASRE1B_MOD/ASRE1B_MOD_VARIANTDESIGNATOR/g s/ASRE1BAD_MOD/ASRE1BAD_MOD_VARIANTDESIGNATOR/g s/BUTTERFLY_ALG_MOD/BUTTERFLY_ALG_MOD_VARIANTDESIGNATOR/g s/CDMAP_MOD/CDMAP_MOD_VARIANTDESIGNATOR/g s/DEALLOC_RESOL_MOD/DEALLOC_RESOL_MOD_VARIANTDESIGNATOR/g s/DIR_TRANS_CTL_MOD/DIR_TRANS_CTL_MOD_VARIANTDESIGNATOR/g s/DIR_TRANS_CTLAD_MOD/DIR_TRANS_CTLAD_MOD_VARIANTDESIGNATOR/g s/dir_trans( *($|\(| |\*))/dir_trans_VARIANTDESIGNATOR\1/g s/DIR_TRANS( *($|\(| |\*))/DIR_TRANS_VARIANTDESIGNATOR\1/g s/dir_transad( *($|\(| |\*))/dir_transad_VARIANTDESIGNATOR\1/g s/DIR_TRANSAD( *($|\(| |\*))/DIR_TRANSAD_VARIANTDESIGNATOR\1/g s/DIST_GRID_32_CTL_MOD/DIST_GRID_32_CTL_MOD_VARIANTDESIGNATOR/g s/dist_grid_32( *($|\(| |\*))/dist_grid_32_VARIANTDESIGNATOR\1/g s/DIST_GRID_32( *($|\(| |\*))/DIST_GRID_32_VARIANTDESIGNATOR\1/g s/DIST_GRID_CTL_MOD/DIST_GRID_CTL_MOD_VARIANTDESIGNATOR/g s/dist_grid( *($|\(| |\*))/dist_grid_VARIANTDESIGNATOR\1/g s/DIST_GRID( *($|\(| |\*))/DIST_GRID_VARIANTDESIGNATOR\1/g s/DIST_SPEC_CONTROL_MOD/DIST_SPEC_CONTROL_MOD_VARIANTDESIGNATOR/g s/dist_spec( *($|\(| |\*))/dist_spec_VARIANTDESIGNATOR\1/g s/DIST_SPEC( *($|\(| |\*))/DIST_SPEC_VARIANTDESIGNATOR\1/g s/ectrans_mod/ectrans_mod_VARIANTDESIGNATOR/g s/FFTB_PLAN/FFTB_PLAN_VARIANTDESIGNATOR/g s/FFTB_TYPE/FFTB_TYPE_VARIANTDESIGNATOR/g s/FOURIER_IN_MOD/FOURIER_IN_MOD_VARIANTDESIGNATOR/g s/FOURIER_INAD_MOD/FOURIER_INAD_MOD_VARIANTDESIGNATOR/g s/FOURIER_OUT_MOD/FOURIER_OUT_MOD_VARIANTDESIGNATOR/g s/FOURIER_OUTAD_MOD/FOURIER_OUTAD_MOD_VARIANTDESIGNATOR/g s/FSC_MOD/FSC_MOD_VARIANTDESIGNATOR/g s/FSCAD_MOD/FSCAD_MOD_VARIANTDESIGNATOR/g s/FSPGL_INT_MOD/FSPGL_INT_MOD_VARIANTDESIGNATOR/g s/FTDIR_CTL_MOD/FTDIR_CTL_MOD_VARIANTDESIGNATOR/g s/FTDIR_CTLAD_MOD/FTDIR_CTLAD_MOD_VARIANTDESIGNATOR/g s/FTDIR_MOD/FTDIR_MOD_VARIANTDESIGNATOR/g s/FTDIRAD_MOD/FTDIRAD_MOD_VARIANTDESIGNATOR/g s/FTINV_CTL_MOD/FTINV_CTL_MOD_VARIANTDESIGNATOR/g s/FTINV_CTLAD_MOD/FTINV_CTLAD_MOD_VARIANTDESIGNATOR/g s/FTINV_MOD/FTINV_MOD_VARIANTDESIGNATOR/g s/FTINVAD_MOD/FTINVAD_MOD_VARIANTDESIGNATOR/g s/GATH_GRID_32_CTL_MOD/GATH_GRID_32_CTL_MOD_VARIANTDESIGNATOR/g s/gath_grid_32( *($|\(| |\*))/gath_grid_32_VARIANTDESIGNATOR\1/g s/GATH_GRID_32( *($|\(| |\*))/GATH_GRID_32_VARIANTDESIGNATOR\1/g s/GATH_GRID_CTL_MOD/GATH_GRID_CTL_MOD_VARIANTDESIGNATOR/g s/gath_grid( *($|\(| |\*))/gath_grid_VARIANTDESIGNATOR\1/g s/GATH_GRID( *($|\(| |\*))/GATH_GRID_VARIANTDESIGNATOR\1/g s/GATH_SPEC_CONTROL_MOD/GATH_SPEC_CONTROL_MOD_VARIANTDESIGNATOR/g s/gath_spec( *($|\(| |\*))/gath_spec_VARIANTDESIGNATOR\1/g s/GATH_SPEC( *($|\(| |\*))/GATH_SPEC_VARIANTDESIGNATOR\1/g s/GPNORM_TRANS_GPU( *($|\(| |\*))/GPNORM_TRANS_GPU_VARIANTDESIGNATOR\1/g s/GPNORM_TRANS_CTL_MOD/GPNORM_TRANS_CTL_MOD_VARIANTDESIGNATOR/g s/gpnorm_trans( *($|\(| |\*))/gpnorm_trans_VARIANTDESIGNATOR\1/g s/GPNORM_TRANS( *($|\(| |\*))/GPNORM_TRANS_VARIANTDESIGNATOR\1/g s/gpnorm_transad( *($|\(| |\*))/gpnorm_transad_VARIANTDESIGNATOR\1/g s/GPNORM_TRANSAD( *($|\(| |\*))/GPNORM_TRANSAD_VARIANTDESIGNATOR\1/g s/GPNORM_TRANS_CTLAD_MOD/GPNORM_TRANS_CTLAD_MOD_VARIANTDESIGNATOR/g s/gpnorm_transtl( *($|\(| |\*))/gpnorm_transtl_VARIANTDESIGNATOR\1/g s/GPNORM_TRANSTL( *($|\(| |\*))/GPNORM_TRANSTL_VARIANTDESIGNATOR\1/g s/GPNORM_TRANS_CTLTL_MOD/GPNORM_TRANS_CTLTL_MOD_VARIANTDESIGNATOR/g s/INIGPTR_MOD/INIGPTR_MOD_VARIANTDESIGNATOR/g s/INV_TRANS_CTL_MOD/INV_TRANS_CTL_MOD_VARIANTDESIGNATOR/g s/INV_TRANS_CTLAD_MOD/INV_TRANS_CTLAD_MOD_VARIANTDESIGNATOR/g s/inv_trans( *($|\(| |\*))/inv_trans_VARIANTDESIGNATOR\1/g s/INV_TRANS( *($|\(| |\*))/INV_TRANS_VARIANTDESIGNATOR\1/g s/inv_transad( *($|\(| |\*))/inv_transad_VARIANTDESIGNATOR\1/g s/INV_TRANSAD/INV_TRANSAD_VARIANTDESIGNATOR/g s/jprbt/TYPEDESIGNATOR_LOWER/g s/JPRBT/TYPEDESIGNATOR_UPPER/g s/jprb/TYPEDESIGNATOR_LOWER/g s/JPRB/TYPEDESIGNATOR_UPPER/g s/JPRH/JPRD/g s/LDFOU2_MOD/LDFOU2_MOD_VARIANTDESIGNATOR/g s/LEDIR_MOD/LEDIR_MOD_VARIANTDESIGNATOR/g s/LEDIRAD_MOD/LEDIRAD_MOD_VARIANTDESIGNATOR/g s/LEINV_MOD/LEINV_MOD_VARIANTDESIGNATOR/g s/LEINVAD_MOD/LEINVAD_MOD_VARIANTDESIGNATOR/g s/LTDIR_CTL_MOD/LTDIR_CTL_MOD_VARIANTDESIGNATOR/g s/LTDIR_CTLAD_MOD/LTDIR_CTLAD_MOD_VARIANTDESIGNATOR/g s/LTDIR_MOD/LTDIR_MOD_VARIANTDESIGNATOR/g s/LTDIRAD_MOD/LTDIRAD_MOD_VARIANTDESIGNATOR/g s/LTINV_CTL_MOD/LTINV_CTL_MOD_VARIANTDESIGNATOR/g s/LTINV_CTLAD_MOD/LTINV_CTLAD_MOD_VARIANTDESIGNATOR/g s/LTINV_MOD/LTINV_MOD_VARIANTDESIGNATOR/g s/LTINVAD_MOD/LTINVAD_MOD_VARIANTDESIGNATOR/g s/parkind1/ec_parkind/g s/PARKIND1/EC_PARKIND/g s/PARKIND2/EC_PARKIND/g s/parkind_ectrans/ec_parkind/g s/PARKIND_ECTRANS/ec_parkind/g s/PREPSNM_MOD/PREPSNM_MOD_VARIANTDESIGNATOR/g s/PRFI1_MOD/PRFI1_MOD_VARIANTDESIGNATOR/g s/PRFI1AD_MOD/PRFI1AD_MOD_VARIANTDESIGNATOR/g s/PRFI1B_MOD/PRFI1B_MOD_VARIANTDESIGNATOR/g s/PRFI1BAD_MOD/PRFI1BAD_MOD_VARIANTDESIGNATOR/g s/PRFI2_MOD/PRFI2_MOD_VARIANTDESIGNATOR/g s/PRFI2AD_MOD/PRFI2AD_MOD_VARIANTDESIGNATOR/g s/PRFI2B_MOD/PRFI2B_MOD_VARIANTDESIGNATOR/g s/PRFI2BAD_MOD/PRFI2BAD_MOD_VARIANTDESIGNATOR/g s/READ_LEGPOL_MOD/READ_LEGPOL_MOD_VARIANTDESIGNATOR/g s/seefmm_mix/seefmm_mix_VARIANTDESIGNATOR/g s/SEEFMM_MIX/SEEFMM_MIX_VARIANTDESIGNATOR/g s/SET_RESOL_MOD/SET_RESOL_MOD_VARIANTDESIGNATOR/g s/SETUP_TRANS( *($|\(| |\*))/SETUP_TRANS_VARIANTDESIGNATOR\1/g s/setup_trans( *($|\(| |\*|\.h))/setup_trans_VARIANTDESIGNATOR\1/g s/specnorm/specnorm_VARIANTDESIGNATOR/g s/SPECNORM/SPECNORM_VARIANTDESIGNATOR/g s/SPNORM_CTL_MOD/SPNORM_CTL_MOD_VARIANTDESIGNATOR/g s/SPNORMC_MOD/SPNORMC_MOD_VARIANTDESIGNATOR/g s/SPNORMD_MOD/SPNORMD_MOD_VARIANTDESIGNATOR/g s/SPNSDE_MOD/SPNSDE_MOD_VARIANTDESIGNATOR/g s/SPNSDEAD_MOD/SPNSDEAD_MOD_VARIANTDESIGNATOR/g s/SUMP_TRANS_MOD/SUMP_TRANS_MOD_VARIANTDESIGNATOR/g s/\ SULEG_MOD/\ SULEG_MOD_VARIANTDESIGNATOR/g s/TPM_FFTW/TPM_FFTW_VARIANTDESIGNATOR/g s/TPM_FIELDS_GPU/TPM_FIELDS_GPU_VARIANTDESIGNATOR/g s/TPM_FLT/TPM_FLT_VARIANTDESIGNATOR/g s/TPM_TRANS/TPM_TRANS_VARIANTDESIGNATOR/g s/trans_end( *($|\(| |\*|\.h))/trans_end_VARIANTDESIGNATOR\1/g s/TRANS_END/TRANS_END_VARIANTDESIGNATOR/g s/trans_inq( *($|\(| |\*))/trans_inq_VARIANTDESIGNATOR\1/g s/TRANS_INQ/TRANS_INQ_VARIANTDESIGNATOR/g s/TRANS_PNM/TRANS_PNM_VARIANTDESIGNATOR/g s/trans_release( *($|\(| |\*|\.h))/trans_release_VARIANTDESIGNATOR\1/g s/TRANS_RELEASE/TRANS_RELEASE_VARIANTDESIGNATOR/g s/TRGTOL_MOD/TRGTOL_MOD_VARIANTDESIGNATOR/g s/TRLTOG_MOD/TRLTOG_MOD_VARIANTDESIGNATOR/g s/TRGL_MOD/TRGL_MOD_VARIANTDESIGNATOR/g s/TRLTOM_MOD/TRLTOM_MOD_VARIANTDESIGNATOR/g s/TRLTOMAD_MOD/TRLTOMAD_MOD_VARIANTDESIGNATOR/g s/TRMTOL_MOD/TRMTOL_MOD_VARIANTDESIGNATOR/g s/TRMTOLAD_MOD/TRMTOLAD_MOD_VARIANTDESIGNATOR/g s/TRMTOL_PACK_UNPACK/TRMTOL_PACK_UNPACK_VARIANTDESIGNATOR/g s/TRMTOLAD_PACK_UNPACK/TRMTOLAD_PACK_UNPACK_VARIANTDESIGNATOR/g s/TRLTOM_PACK_UNPACK/TRLTOM_PACK_UNPACK_VARIANTDESIGNATOR/g s/TRLTOMAD_PACK_UNPACK/TRLTOMAD_PACK_UNPACK_VARIANTDESIGNATOR/g s/UPDSP_MOD/UPDSP_MOD_VARIANTDESIGNATOR/g s/UPDSPAD_MOD/UPDSPAD_MOD_VARIANTDESIGNATOR/g s/UPDSPB_MOD/UPDSPB_MOD_VARIANTDESIGNATOR/g s/UPDSPBAD_MOD/UPDSPBAD_MOD_VARIANTDESIGNATOR/g s/UVTVD_MOD/UVTVD_MOD_VARIANTDESIGNATOR/g s/UVTVDAD_MOD/UVTVDAD_MOD_VARIANTDESIGNATOR/g s/VD2UV_CTL_MOD/VD2UV_CTL_MOD_VARIANTDESIGNATOR/g s/VD2UV_MOD/VD2UV_MOD_VARIANTDESIGNATOR/g s/VDTUV_MOD/VDTUV_MOD_VARIANTDESIGNATOR/g s/VDTUVAD_MOD/VDTUVAD_MOD_VARIANTDESIGNATOR/g s/VORDIV_TO_UV/VORDIV_TO_UV_VARIANTDESIGNATOR/g s/WRITE_LEGPOL_MOD/WRITE_LEGPOL_MOD_VARIANTDESIGNATOR/g ectrans-1.8.0/src/trans/gpu/0000775000175000017500000000000015174631767016075 5ustar alastairalastairectrans-1.8.0/src/trans/gpu/internal/0000775000175000017500000000000015174631767017711 5ustar alastairalastairectrans-1.8.0/src/trans/gpu/internal/prfi1_mod.F900000775000175000017500000000640315174631767022057 0ustar alastairalastair! (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. ! MODULE PRFI1_MOD CONTAINS SUBROUTINE PRFI1(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& & KFLDPTRUV,KFLDPTRSC) USE PARKIND1, ONLY: JPIM, JPRB USE PRFI1B_MOD, ONLY: PRFI1B !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPVOR - vorticity ! PSPDIV - divergence ! PSPSCALAR - scalar variables ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1 in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PIA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR stop 'Error: prfi1 not (yet) supported in GPU version' ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! ------------------------------------ ! IFIRST = 1 ! ILAST = 4*KF_UV ! !* 1.1 VORTICITY AND DIVERGENCE. ! IF(KF_UV > 0)THEN ! IVOR = 1 ! IDIV = 2*KF_UV+1 ! CALL PRFI1B(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) ! CALL PRFI1B(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) ! ILAST = ILAST+4*KF_UV ! ENDIF ! !* 1.2 SCALAR VARIABLES. ! IF(KF_SCALARS > 0)THEN ! IFIRST = ILAST+1 ! ILAST = IFIRST - 1 + 2*KF_SCALARS ! CALL PRFI1B(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ! ENDIF ! ------------------------------------------------------------------ END SUBROUTINE PRFI1 END MODULE PRFI1_MOD ectrans-1.8.0/src/trans/gpu/internal/cdmap_mod.F900000775000175000017500000001263515174631767022126 0ustar alastairalastair! (C) Copyright 2014- ECMWF. ! (C) Copyright 2014- 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. ! MODULE CDMAP_MOD CONTAINS SUBROUTINE CDMAP(KM,KMLOC,KSL,KSLO,PEPSNM, KDIR, KDGNH, KDGNHD,& & KFIELDS, PCOEFA, PCOEFS) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_FLT, ONLY: S USE TPM_DISTR, ONLY: D !USE TPM_TRANS, ONLY: FOUBUF_IN, FOUBUF USE SEEFMM_MIX, ONLY: SEEFMM_MULM USE MPL_MODULE, ONLY: MPL_ABORT !**** *CDMAP* - REMAP ROOTS ! ! Purpose. ! -------- ! remap from one set of roots to another using Christoffel-Darboux formula, see Chien + Alpert, 1997. !** Interface. ! ---------- ! *CALL* *CDMAP(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! Chien + Alpert, 1997. ! Author. ! ------- ! Nils Wedi *ECMWF* ! Modifications. ! -------------- ! Original : 14-05-14 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KSL INTEGER(KIND=JPIM), INTENT(IN) :: KSLO REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM INTEGER(KIND=JPIM), INTENT(IN) :: KDIR ! direction of map INTEGER(KIND=JPIM), INTENT(IN) :: KDGNH INTEGER(KIND=JPIM), INTENT(IN) :: KDGNHD INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS REAL(KIND=JPRBT), INTENT(INOUT) :: PCOEFA(:,:) REAL(KIND=JPRBT), INTENT(INOUT) :: PCOEFS(:,:) INTEGER(KIND=JPIM) :: JGL, IGL, JF REAL(KIND=JPRBT), ALLOCATABLE :: ZALL(:,:), ZQX(:,:) REAL(KIND=JPRBT), ALLOCATABLE :: ZALL1(:,:), ZQY(:,:) INTEGER(KIND=JPIM) :: ISTN(KDGNH), ISTS(KDGNH) INTEGER(KIND=JPIM) :: IGLS, IPROC, IPROCS, IEND, IENDO REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ CALL MPL_ABORT("CDMAP not yet supported in ecTrans GPU version") !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('CDMAP_MOD',0,ZHOOK_HANDLE) IF( KDIR == -1 ) THEN ! inverse map from internal (gg) roots to post-processing roots IENDO = 2*KDGNHD - KSLO + 1 IEND = 2*KDGNH - KSL + 1 !!!!! fourier buffer setup in output latitudes, may not work if different from input !!!! DO IGL=KSLO, KDGNHD IPROC = D%NPROCL(IGL) ISTN(IGL) = (D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,IGL))*KFIELDS IGLS = 2*KDGNH+1-IGL IPROCS = D%NPROCL(IGLS) ISTS(IGL) = (D%NSTAGT0B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*KFIELDS ENDDO ALLOCATE(ZALL(KFIELDS, 2*KDGNHD)) ALLOCATE(ZALL1(KFIELDS, 2*KDGNHD)) ALLOCATE(ZQX(KFIELDS, 2*KDGNH)) ALLOCATE(ZQY(KFIELDS, 2*KDGNH)) ZQX(:,1:KSL) = 0._JPRBT ZQX(:,IEND:2*KDGNH) = 0._JPRBT ZQY(:,1:KSL) = 0._JPRBT ZQY(:,IEND:2*KDGNH) = 0._JPRBT DO JGL=KSL, IEND ZQX(1:KFIELDS,JGL)=S%FA(KMLOC)%RPNMWI(JGL-KSL+1,1)*PCOEFA(1:KFIELDS,JGL) ZQY(1:KFIELDS,JGL)=S%FA(KMLOC)%RPNMWI(JGL-KSL+1,2)*PCOEFA(1:KFIELDS,JGL) ENDDO CALL SEEFMM_MULM(S%FMM_INTI,KFIELDS,1_JPIM,.TRUE.,ZQX,ZALL1) CALL SEEFMM_MULM(S%FMM_INTI,KFIELDS,1_JPIM,.TRUE.,ZQY,ZALL) DEALLOCATE(ZQX) DEALLOCATE(ZQY) ! minus sign comes from FMM ?! ! fill buffer DO IGL=KSLO,KDGNHD IGLS = 2*KDGNHD+1-IGL DO JF=1,KFIELDS !FOUBUF_IN(ISTN(IGL)+JF) = S%FA(KMLOC)%RPNMWO(IGL-KSLO+1,1)*ZALL1(JF,IGL) & ! & - S%FA(KMLOC)%RPNMWO(IGL-KSLO+1,2)*ZALL(JF,IGL) !FOUBUF_IN(ISTS(IGL)+JF) = S%FA(KMLOC)%RPNMWO(IGLS-KSLO+1,1)*ZALL1(JF,IGLS) & ! & - S%FA(KMLOC)%RPNMWO(IGLS-KSLO+1,2)*ZALL(JF,IGLS) ENDDO ENDDO DEALLOCATE(ZALL1) DEALLOCATE(ZALL) ELSE ! direct map from post-processing/input field roots to internal (gg) roots ! this assumes essentially a nearest neighbour interpolation in latitude ! a more accurate approach may be ! a local gridpoint interpolation of the input field to the target latitudes prior to the transforms IENDO = 2*KDGNHD - KSLO + 1 IEND = 2*KDGNH - KSL + 1 !!!!! fourier buffer setup in input data latitudes, may not work if different from output !!!! DO JGL=KSLO, KDGNHD IPROC = D%NPROCL(JGL) ISTN(JGL) = (D%NSTAGT1B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*KFIELDS IGLS = 2*KDGNHD+1-JGL IPROCS = D%NPROCL(IGLS) ISTS(JGL) = (D%NSTAGT1B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*KFIELDS ENDDO ALLOCATE( ZQX( KFIELDS, 2*KDGNHD)) ZQX(:,1:KSLO) = 0._JPRBT ZQX(:,IENDO:2*KDGNHD) = 0._JPRBT DO JGL=KSLO, KDGNHD IGLS = 2*KDGNHD+1-JGL DO JF=1,KFIELDS !ZQX(JF,JGL)=FOUBUF(ISTN(JGL)+JF) !ZQX(JF,IGLS)=FOUBUF(ISTS(JGL)+JF) ENDDO ENDDO ! split into symmetric / antisymmetric DO IGL=KSL,KDGNH IGLS = 2*KDGNH+1-IGL PCOEFS(1:KFIELDS,IGL) = ZQX(1:KFIELDS,IGL) + ZQX(1:KFIELDS,IGLS) PCOEFA(1:KFIELDS,IGL) = ZQX(1:KFIELDS,IGL) - ZQX(1:KFIELDS,IGLS) ENDDO DEALLOCATE(ZQX) ENDIF IF (LHOOK) CALL DR_HOOK('CDMAP_MOD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE CDMAP END MODULE CDMAP_MOD ectrans-1.8.0/src/trans/gpu/internal/gath_grid_32_ctl_mod.F900000775000175000017500000001731315174631767024136 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! ! 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. ! MODULE GATH_GRID_32_CTL_MOD CONTAINS SUBROUTINE GATH_GRID_32_CTL(PGPG,KFGATHG,KPROMA,KTO,PGP) !**** *GATH_GRID_32_CTL* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Routine for gathering gridpoint array !** Interface. ! ---------- ! CALL GATH_GRID_32_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! PGP(:,:,:) - Local spectral array ! ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRM USE MPL_MODULE, ONLY: MPL_SEND, JP_NON_BLOCKING_STANDARD, MPL_RECV, JP_BLOCKING_STANDARD, & & MPL_WAIT, MPL_ALLTOALLV USE TPM_GEOMETRY, ONLY: G USE TPM_DISTR, ONLY: D, NPROC, MYPROC, MTAGDISTSP, NPRCIDS USE SET2PE_MOD, ONLY: SET2PE USE EQ_REGIONS_MOD, ONLY: N_REGIONS_NS, N_REGIONS IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) REAL(KIND=JPRM) , INTENT(IN) :: PGP(:,:,:) ! Declaration of local variables REAL(KIND=JPRM) :: ZFLD(D%NGPTOTMX*KFGATHG) REAL(KIND=JPRM),ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) :: IFLDR,JFLD,ITAG,ILEN,JA,JB,ISND,JGL,JLON,ILOFF,IST INTEGER(KIND=JPIM) :: IRCV,IOFF,ILAST,IGL1,IGL2,IGLOFF INTEGER(KIND=JPIM) :: JKGLO,JROF,IEND,J,IBL,IPROC,JROC,IMYFIELDS,ILRECV INTEGER(KIND=JPIM) :: ISENDREQ(NPROC),ITO INTEGER(KIND=JPIM) :: ILENS(NPROC),IOFFS(NPROC),ILENR(NPROC),IOFFR(NPROC) INTEGER(KIND=JPIM) :: IFLDL,IFLDS LOGICAL :: LLSAME ! ------------------------------------------------------------------ !GATHER SPECTRAL ARRAY IF( NPROC == 1 ) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFGATHG DO JROF=1,IEND PGPG(IOFF+JROF,JFLD) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ! test if values in KTO are all the same LLSAME=.TRUE. ITO=KTO(1) DO JFLD=2,KFGATHG IF(KTO(JFLD) /= ITO) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO IFLDL=D%NGPTOTMX IF(LLSAME) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JFLD=1,KFGATHG DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+(JFLD-1)*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ILENS(:)=0 IOFFS(:)=0 ILENR(:)=0 IOFFR(:)=0 DO JFLD=1,KFGATHG ILENS(KTO(JFLD))=ILENS(KTO(JFLD))+IFLDL IF(KTO(JFLD) == MYPROC) THEN ILENR(:)=ILENR(:)+IFLDL ENDIF ENDDO DO JROC=2,NPROC IOFFR(JROC)=IOFFR(JROC-1)+ ILENR(JROC-1) IOFFS(JROC)=IOFFS(JROC-1)+ ILENS(JROC-1) ENDDO IFLDS=0 DO JROC=1,NPROC IF(ILENS(JROC) > 0) THEN DO JFLD=1,KFGATHG IF(KTO(JFLD) == JROC) THEN DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+IFLDS*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO IFLDS=IFLDS+1 ENDIF ENDDO ENDIF ENDDO ENDIF IMYFIELDS = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX*IMYFIELDS*NPROC)) ELSE ALLOCATE(ZBUF(1)) ENDIF IFLDR = 0 CALL GSTATS_BARRIER(789) CALL GSTATS(809,0) IF( LLSAME )THEN !Send ISND = KTO(1) ITAG = MTAGDISTSP+1+17 CALL MPL_SEND(ZFLD,KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(1),& &CDSTRING='GATH_GRID_32_CTL:') ! RECIEVE IF(KTO(1) == MYPROC) THEN IFLDR = KFGATHG DO JROC=1,NPROC ITAG = MTAGDISTSP+1+17 IRCV = JROC IOFF=IFLDL*KFGATHG*(JROC-1) CALL MPL_RECV(ZBUF(IOFF+1:IOFF+IFLDL*KFGATHG),KSOURCE=NPRCIDS(IRCV),& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILRECV,& &KTAG=ITAG,CDSTRING='GATH_GRID_32_CTL:') ENDDO ENDIF CALL MPL_WAIT(KREQUEST=ISENDREQ(1), & & CDSTRING='GATH_GRID_32_CTL: WAIT') ELSE IFLDR=IMYFIELDS CALL MPL_ALLTOALLV(PSENDBUF=ZFLD,KSENDCOUNTS=ILENS,& & PRECVBUF=ZBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& & CDSTRING='GATH_GRID_32_CTL:') !!$ ITAG = MTAGDISTSP+1+17 !!$ DO JROC=1,NPROC !!$ ISND=JROC !!$ IOFF=IOFFS(JROC) !!$ ILEN=ILENS(JROC) !!$ IF(ILEN > 0 ) THEN !!$ CALL MPL_SEND(ZFLD(IOFF+1:IOFF+ILEN),KDEST=NPRCIDS(ISND),KTAG=ITAG,& !!$ &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISND),& !!$ &CDSTRING='GATH_GRID_32_CTL:') !!$ ENDIF !!$ ENDDO !!$ DO JROC=1,NPROC !!$ IRCV = JROC !!$ IOFF = IOFFR(JROC) !!$ ILEN = ILENR(JROC) !!$ IF(ILEN > 0 ) THEN !!$ CALL MPL_RECV(ZBUF(IOFF+1:IOFF+ILEN),KSOURCE=NPRCIDS(IRCV),& !!$ &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILRECV,& !!$ &KTAG=ITAG,CDSTRING='GATH_GRID_32_CTL:') !!$ ENDIF !!$ ENDDO !!$ DO JROC=1,NPROC !!$ ISND=JROC !!$ ILEN=ILENS(JROC) !!$ IF(ILEN > 0 ) THEN !!$ CALL MPL_WAIT(KREQUEST=ISENDREQ(JROC), & !!$ & CDSTRING='GATH_GRID_32_CTL: WAIT') !!$ ENDIF !!$ ENDDO ENDIF CALL GSTATS(809,1) CALL GSTATS_BARRIER2(789) CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JA,JB,IPROC,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILEN,ILOFF,JGL,JLON,JFLD) DO JFLD=1,IFLDR DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(IPROC,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) = & & ZBUF(ILEN+JLON+(JFLD-1)*IFLDL+(IPROC-1)*IFLDL*IMYFIELDS) ENDDO ILEN = ILEN + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ! Synhronize processors ! Should not be necessary !!$ CALL GSTATS(784,0) !!$ CALL MPL_BARRIER(CDSTRING='GATH_GRID_32_CTL:') !!$ CALL GSTATS(784,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID_32_CTL END MODULE GATH_GRID_32_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/dealloc_resol_mod.F900000775000175000017500000001027715174631767023651 0ustar alastairalastair! (C) Copyright 2013- ECMWF. ! (C) Copyright 2013- Meteo-France. ! (C) Copyright 2024- NVIDIA. ! ! 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. ! MODULE DEALLOC_RESOL_MOD CONTAINS SUBROUTINE DEALLOC_RESOL(KRESOL) !**** *DEALLOC_RESOL* - Deallocations of a resolution ! Purpose. ! -------- ! Release allocated arrays for a given resolution !** Interface. ! ---------- ! CALL DEALLOC_RESOL ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 from trans_end ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM USE TPM_DIM, ONLY: R, DIM_TYPE USE TPM_GEN, ONLY: LENABLED, NOUT, NDEF_RESOL USE TPM_DISTR, ONLY: D, DISTR_TYPE, NPRTRV USE TPM_GEOMETRY, ONLY: G, GEOM_TYPE USE TPM_FIELDS, ONLY: F, FIELDS_TYPE USE TPM_FIELDS_GPU, ONLY: FG, FIELDS_GPU_TYPE USE TPM_HICFFT, ONLY: CLEAN_FFT USE HICBLAS_MOD, ONLY: CLEAN_GEMM USE TPM_FLT, ONLY: S, FLT_TYPE_WRAP USE TPM_CTL, ONLY: C USE SEEFMM_MIX, ONLY: FREE_SEEFMM USE SET_RESOL_MOD, ONLY: SET_RESOL ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) :: JMLOC,IPRTRV,JSETV,IMLOC,IM,ILA,ILS, JRESOL TYPE(DIM_TYPE) :: R_ TYPE(DISTR_TYPE) :: D_ TYPE(GEOM_TYPE) :: G_ TYPE(FIELDS_TYPE) :: F_ TYPE(FIELDS_GPU_TYPE) :: FG_ TYPE(FLT_TYPE_WRAP) :: S_ ! ------------------------------------------------------------------ IF (.NOT.LENABLED(KRESOL)) THEN WRITE(UNIT=NOUT,FMT='('' DEALLOC_RESOL WARNING : KRESOL = '',I3,'' ALREADY DISABLED '')') KRESOL ELSE CALL SET_RESOL(KRESOL) #ifdef ACCGPU !$ACC EXIT DATA DELETE(R) ASYNC(1) !$ACC EXIT DATA DELETE(FG%ZAA0,FG%ZAS0) IF(ALLOCATED(FG%ZAA0)) ASYNC(1) !$ACC EXIT DATA DELETE(FG%ZAA,FG%ZAS,FG%ZEPSNM) ASYNC(1) !$ACC EXIT DATA DELETE(FG) ASYNC(1) !$ACC EXIT DATA DELETE(F,F%RLAPIN,F%RACTHE,F%RW) ASYNC(1) !$ACC EXIT DATA DELETE(D,D%MYMS,D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,D%NPROCM)& !$ACC& DELETE(D%NPROCL,D%NPTRLS,D%MSTABF,D%NASM0,D%OFFSETS_GEMM1,D%OFFSETS_GEMM2) ASYNC(1) !$ACC EXIT DATA DELETE(G,G%NDGLU,G%NMEN,G%NLOEN) ASYNC(1) !$ACC WAIT(1) #endif #ifdef OMPGPU #endif ! TPM_FLD is more complex because it has pointers IF( ALLOCATED(S%FA) ) THEN DO JMLOC=1,D%NUMP,NPRTRV ! +++++++++++++++++++++ JMLOC LOOP ++++++++++ IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMA)) DEALLOCATE(S%FA(IMLOC)%RPNMA) IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMS)) DEALLOCATE(S%FA(IMLOC)%RPNMS) IF(S%LDLL) THEN IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMWI)) DEALLOCATE(S%FA(IMLOC)%RPNMWI) IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMWO)) DEALLOCATE(S%FA(IMLOC)%RPNMWO) ENDIF ENDDO ENDDO DEALLOCATE(S%FA) ENDIF IF(S%LDLL) THEN CALL FREE_SEEFMM(S%FMM_INTI) IF(ASSOCIATED(S%FMM_INTI)) DEALLOCATE(S%FMM_INTI) ENDIF S = S_ ! Empty all fields (none of them has pointers; allocatable arrays implicitly deallocate) R_%NSMAX = 0 ! Avoids warning of unused R_ with Cray compiler D = D_ F = F_ FG = FG_ R = R_ G = G_ CALL CLEAN_FFT(KRESOL) CALL CLEAN_GEMM(KRESOL) LENABLED(KRESOL)=.FALSE. NDEF_RESOL = COUNT(LENABLED) ! Do not stay on a disabled resolution DO JRESOL=1,SIZE(LENABLED) IF (LENABLED(JRESOL)) THEN CALL SET_RESOL(JRESOL) EXIT ENDIF ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DEALLOC_RESOL END MODULE DEALLOC_RESOL_MOD ectrans-1.8.0/src/trans/gpu/internal/ltinv_mod.F900000775000175000017500000003546315174631767022202 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE LTINV_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: LTINV, LTINV_HANDLE, PREPARE_LTINV TYPE LTINV_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPIA_AND_IN TYPE(ALLOCATION_RESERVATION_HANDLE) :: HOUTS_AND_OUTA END TYPE CONTAINS FUNCTION PREPARE_LTINV(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) RESULT(HLTINV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE TPM_DISTR, ONLY: D USE TPM_DIM, ONLY: R USE ISO_C_BINDING, ONLY: C_SIZEOF USE LEINV_MOD, ONLY: LEINV_STRIDES USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS LOGICAL, INTENT(IN) :: LVORGP,LDIVGP,LSCDERS TYPE(LTINV_HANDLE) :: HLTINV INTEGER(KIND=JPIB) :: IALLOC_SZ, IPIA_SZ INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE REAL(KIND=JPRBT) :: ZPRBT_DUMMY REAL(KIND=JPRD) :: ZPRD_DUMMY INTEGER(KIND=JPIM) :: IF_READIN, IF_LEG ! # fields that are initially read. We always read vorticity ! and divergence! Also keep in mind that we actually have 2X ! this number of levels because real+complex IF_READIN = 0 IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! U IF_READIN = IF_READIN + KF_UV ! V IF_READIN = IF_READIN + KF_SCALARS ! Scalars IF (LSCDERS) & IF_READIN = IF_READIN + KF_SCALARS ! Scalars NS Derivatives IPIA_SZ = ALIGN(2_JPIB*IF_READIN*(R%NSMAX+3)*D%NUMP*C_SIZEOF(ZPRBT_DUMMY),128) ! In Legendre space, we then ignore vorticity/divergence, if ! they don't need to be transformed. IF_LEG = IF_READIN IF(.NOT. LVORGP) IF_LEG = IF_LEG - KF_UV ! No vorticity needed IF(.NOT. LDIVGP) IF_LEG = IF_LEG - KF_UV ! No divergence needed CALL LEINV_STRIDES(IF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) ! PIA IALLOC_SZ = IPIA_SZ ! ZINP IALLOC_SZ = IALLOC_SZ + ALIGN(IIN_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZINP0 IALLOC_SZ = IALLOC_SZ + ALIGN(IIN0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HLTINV%HPIA_AND_IN = RESERVE(ALLOCATOR, IALLOC_SZ, "HLTINV_HPIA_AND_IN") IALLOC_SZ = 0 ! ZOUTA IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUTS IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUTA0 IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) ! ZOUTS0 IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HLTINV%HOUTS_AND_OUTA = RESERVE(ALLOCATOR, IALLOC_SZ, "HLTINV_HOUTS_AND_OUTA") END FUNCTION PREPARE_LTINV SUBROUTINE LTINV(ALLOCATOR,HLTINV,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & & ZOUTS,ZOUTA,ZOUTS0,ZOUTA0) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPRD, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_TRANS, ONLY: LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B, LSCDERS USE TPM_GEOMETRY, ONLY: G USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_DISTR, ONLY: D USE PRFI1B_MOD, ONLY: PRFI1B USE VDTUV_MOD, ONLY: VDTUV USE SPNSDE_MOD, ONLY: SPNSDE USE LEINV_MOD, ONLY: LEINV_STRIDES, LEINV USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE TPM_FIELDS_GPU, ONLY: FG USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_GEN, ONLY: LSYNC_TRANS USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE ISO_C_BINDING, ONLY: C_LOC, C_SIZEOF, C_F_POINTER !**** *LTINV* - Inverse Legendre transform ! ! Purpose. ! -------- ! Tranform from Laplace space to Fourier space, compute U and V ! and north/south derivatives of state variables. !** Interface. ! ---------- ! *CALL* *LTINV(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : The Laplace arrays of the model. ! -------------------- The values of the Legendre polynomials ! The grid point arrays of the model ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1B - prepares the spectral fields ! VDTUV - compute u and v from vorticity and divergence ! SPNSDE - compute north-south derivatives ! LEINV - Inverse Legendre transform ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINV in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRBT), POINTER, INTENT(OUT) :: ZOUTS(:), ZOUTA(:) REAL(KIND=JPRD), POINTER, INTENT(OUT) :: ZOUTS0(:), ZOUTA0(:) INTEGER(KIND=JPIM) :: IFIRST, J3 REAL(KIND=JPRB), POINTER :: PIA_L(:), PIA(:,:,:) REAL(KIND=JPRB), POINTER :: PU(:,:,:), PV(:,:,:), PVOR(:,:,:), PDIV(:,:,:) REAL(KIND=JPRB), POINTER :: PSCALARS(:,:,:), PSCALARS_NSDER(:,:,:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(LTINV_HANDLE), INTENT(IN) :: HLTINV INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE INTEGER(KIND=JPIM) :: IF_READIN, IF_LEG INTEGER(KIND=JPIB) :: IALLOC_POS, IALLOC_SZ REAL(KIND=JPRBT), POINTER :: ZINP(:) REAL(KIND=JPRD), POINTER :: ZINP0(:) ASSOCIATE(ZEPSNM=>FG%ZEPSNM) ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('LTINV_MOD',0,ZHOOK_HANDLE) ! Get all pointers IF_READIN = 0 IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! U IF_READIN = IF_READIN + KF_UV ! V IF_READIN = IF_READIN + KF_SCALARS ! Scalars IF (LSCDERS) & IF_READIN = IF_READIN + KF_SCALARS ! Scalars NS Derivatives ! In Legendre space, we then ignore vorticity/divergence, if ! they don't need to be transformed. IF_LEG = IF_READIN IF(.NOT. LVORGP) IF_LEG = IF_LEG - KF_UV ! No vorticity needed IF(.NOT. LDIVGP) IF_LEG = IF_LEG - KF_UV ! No divergence needed CALL LEINV_STRIDES(IF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) IALLOC_POS = 1 ! PIA IALLOC_SZ = ALIGN(2_JPIB*IF_READIN*(R%NTMAX+3)*D%NUMP*C_SIZEOF(PIA_L(1)),128) CALL ASSIGN_PTR(PIA_L, GET_ALLOCATION(ALLOCATOR, HLTINV%HPIA_AND_IN),& & IALLOC_POS, IALLOC_SZ) CALL C_F_POINTER(C_LOC(PIA_L), PIA, (/ 2*IF_READIN, R%NTMAX+3, D%NUMP /)) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZINP IALLOC_SZ = ALIGN(IIN_SIZE*C_SIZEOF(ZINP(1)),128) CALL ASSIGN_PTR(ZINP, GET_ALLOCATION(ALLOCATOR, HLTINV%HPIA_AND_IN),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZINP0 IALLOC_SZ = ALIGN(IIN0_SIZE*C_SIZEOF(ZINP0(1)),128) CALL ASSIGN_PTR(ZINP0, GET_ALLOCATION(ALLOCATOR, HLTINV%HPIA_AND_IN),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ IALLOC_POS = 1 ! ZOUTA IALLOC_SZ = ALIGN(IOUT_SIZE*C_SIZEOF(ZOUTA(1)),128) CALL ASSIGN_PTR(ZOUTA, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUTS IALLOC_SZ = ALIGN(IOUT_SIZE*C_SIZEOF(ZOUTS(1)),128) CALL ASSIGN_PTR(ZOUTS, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUTA0 IALLOC_SZ = ALIGN(IOUT0_SIZE*C_SIZEOF(ZOUTA0(1)),128) CALL ASSIGN_PTR(ZOUTA0, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUTS0 IALLOC_SZ = ALIGN(IOUT0_SIZE*C_SIZEOF(ZOUTS0(1)),128) CALL ASSIGN_PTR(ZOUTS0, GET_ALLOCATION(ALLOCATOR, HLTINV%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! Assign pointers do the different components of PIA IFIRST = 0 IF (.NOT. LVORGP .OR. LDIVGP) THEN ! Usually we want to store vorticity first PVOR => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Vorticity PDIV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Divergence ELSE ! Except if we want to translate Vorticity but not Divergence, we should have Divergence first ! Then we have all buffers that move on in a contiguous buffer PDIV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Divergence PVOR => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Vorticity ENDIF PU => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! U PV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! V PSCALARS => PIA(IFIRST+1:IFIRST+2*KF_SCALARS,:,:) IFIRST = IFIRST + 2*KF_SCALARS ! Scalars IF (LSCDERS) THEN PSCALARS_NSDER => PIA(IFIRST+1:IFIRST+2*KF_SCALARS,:,:) IFIRST = IFIRST + 2*KF_SCALARS ! Scalars NS Derivatives ENDIF ! ------------------------------------------------------------------ !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- IF (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(422,0) #ifdef OMPGPU !$OMP TARGET DATA MAP(TO:PSPVOR,PSPDIV) IF(KF_UV > 0) !$OMP TARGET DATA MAP(TO:PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$OMP TARGET DATA MAP(TO:PSPSC2) IF(NF_SC2 > 0) !$OMP TARGET DATA MAP(TO:PSPSC3A) IF(NF_SC3A > 0) !$OMP TARGET DATA MAP(TO:PSPSC3B) IF(NF_SC3B > 0) #endif #ifdef ACCGPU !$ACC DATA COPYIN(PSPVOR,PSPDIV) IF(KF_UV > 0) !$ACC DATA COPYIN(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$ACC DATA COPYIN(PSPSC2) IF(NF_SC2 > 0) !$ACC DATA COPYIN(PSPSC3A) IF(NF_SC3A > 0) !$ACC DATA COPYIN(PSPSC3B) IF(NF_SC3B > 0) #endif IF (LSYNC_TRANS) THEN CALL GSTATS(442,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(442,1) ENDIF CALL GSTATS(422,1) IF (KF_UV > 0) THEN CALL PRFI1B(PVOR,PSPVOR,KF_UV,UBOUND(PSPVOR,2)) CALL PRFI1B(PDIV,PSPDIV,KF_UV,UBOUND(PSPDIV,2)) ! Compute U and V for VOR and DIV CALL VDTUV(KF_UV,ZEPSNM,PVOR,PDIV,PU,PV) ENDIF IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN CALL PRFI1B(PSCALARS,PSPSCALAR,KF_SCALARS,UBOUND(PSPSCALAR,2)) ELSE IFIRST = 1 IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN CALL PRFI1B(PSCALARS(IFIRST:IFIRST+2*NF_SC2-1,:,:),PSPSC2(:,:),NF_SC2,UBOUND(PSPSC2,2)) IFIRST = IFIRST+2*NF_SC2 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN DO J3=1,UBOUND(PSPSC3A,3) CALL PRFI1B(PSCALARS(IFIRST:IFIRST+2*NF_SC3A-1,:,:),PSPSC3A(:,:,J3),NF_SC3A,UBOUND(PSPSC3A,2)) IFIRST = IFIRST+2*NF_SC3A ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN DO J3=1,UBOUND(PSPSC3B,3) CALL PRFI1B(PSCALARS(IFIRST:IFIRST+2*NF_SC3B-1,:,:),PSPSC3B(:,:,J3),NF_SC3B,UBOUND(PSPSC3B,2)) IFIRST = IFIRST+2*NF_SC3B ENDDO ENDIF IF(IFIRST-1 /= 2*KF_SCALARS) THEN WRITE(0,*) 'LTINV:KF_SCALARS,IFIRST',KF_SCALARS,IFIRST CALL ABORT_TRANS('LTINV_MOD:IFIRST /= 2*KF_SCALARS') ENDIF ENDIF ENDIF ! Compute NS derivatives if needed IF (LSCDERS) THEN CALL SPNSDE(KF_SCALARS,ZEPSNM,PSCALARS,PSCALARS_NSDER) ENDIF #ifdef OMPGPU !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif ! ------------------------------------------------------------------ !* 4. INVERSE LEGENDRE TRANSFORM. ! --------------------------- ! Legendre transforms. When converting PIA into ZOUT, we ignore the first entries of LEINV. ! This is because vorticity and divergence is not necessarily converted to GP space. CALL LEINV(ALLOCATOR,PIA(2*(IF_READIN-IF_LEG)+1:IF_READIN,:,:),ZINP,ZINP0,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,IF_LEG) IF (LHOOK) CALL DR_HOOK('LTINV_MOD',1,ZHOOK_HANDLE) END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE LTINV END MODULE LTINV_MOD ectrans-1.8.0/src/trans/gpu/internal/tpm_flt.F900000775000175000017500000000367715174631767021656 0ustar alastairalastair! (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. ! MODULE TPM_FLT USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD USE SEEFMM_MIX, ONLY: FMM_TYPE IMPLICIT NONE SAVE TYPE FLT_TYPE INTEGER(KIND=JPIM) :: NSPOLEGL INTEGER(KIND=JPIM) :: NDGNH INTEGER(KIND=JPIM) :: INS2 INTEGER(KIND=JPIM) :: INA2 REAL(KIND=JPRBT) ,POINTER :: RPNMS(:,:) ! Legendre polynomials REAL(KIND=JPRBT) ,POINTER :: RPNMA(:,:) ! Legendre polynomials REAL(KIND=JPRD) ,POINTER :: RPNMDS(:,:) ! Legendre polynomials REAL(KIND=JPRD) ,POINTER :: RPNMDA(:,:) ! Legendre polynomials REAL(KIND=JPRBT) :: RCS REAL(KIND=JPRBT) :: RCA !REAL(KIND=JPRBT) ,POINTER :: RPNMCDO(:,:) ! Legendre polynomials for C-D formula at orig roots !REAL(KIND=JPRBT) ,POINTER :: RPNMCDD(:,:) ! Legendre polynomials for C-D formula at dual roots REAL(KIND=JPRBT) ,POINTER :: RPNMWI(:,:) ! special weights REAL(KIND=JPRBT) ,POINTER :: RPNMWO(:,:) ! special weights INTEGER(KIND=JPIM) :: ISLD ! starting latitude dual END TYPE FLT_TYPE TYPE FLT_TYPE_WRAP TYPE(FLT_TYPE),ALLOCATABLE :: FA(:) LOGICAL :: LDLL LOGICAL :: LSHIFTLL LOGICAL :: LUSE_BELUSOV LOGICAL :: LKEEPRPNM LOGICAL :: LSOUTHPNM ! .TRUE. to compute Legendre polynomials on southern hemisphere INTEGER(KIND=JPIM) :: IMLOC INTEGER(KIND=JPIM) :: ITHRESHOLD INTEGER(KIND=JPIM) :: NDGNHD ! dual set dimension INTEGER(KIND=JPIM) :: NDLON ! dual number of longitudes INTEGER(KIND=JPIM) :: NDGL ! dual number of latitudes TYPE(FMM_TYPE),POINTER :: FMM_INTI ! FMM interpolation END TYPE FLT_TYPE_WRAP TYPE(FLT_TYPE_WRAP),ALLOCATABLE,TARGET :: FLT_RESOL(:) TYPE(FLT_TYPE_WRAP),POINTER :: S END MODULE TPM_FLT ectrans-1.8.0/src/trans/gpu/internal/updspb_mod.F900000775000175000017500000001064215174631767022333 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE UPDSPB_MOD CONTAINS SUBROUTINE UPDSPB(KFIELD,POA,PSPEC,KFLDPTR) !**** *UPDSPB* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update spectral arrays for a fixed zonal wave-number ! from values in POA. !** Interface. ! ---------- ! CALL UPDSPB(....) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFIELD - number of fields ! POA - work array ! PSPEC - spectral array ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the ! first and last field ! L. Isaksen : 95-06-06 Reordering of spectral arrays ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRBT) ,INTENT(IN) :: POA(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: KM,KMLOC INTEGER(KIND=JPIM) :: INM, IR, JFLD, JN, IASM0 ! ------------------------------------------------------------------ !* 0. NOTE. ! ----- ! The following transfer reads : ! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) ! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) ! with n from m to NSMAX ! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. ! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) ! nn is the loop index. ASSOCIATE(D_NUMP=>D%NUMP, D_MYMS=>D%MYMS, D_NASM0=>D%NASM0, R_NTMAX=>R%NTMAX) IF(PRESENT(KFLDPTR)) THEN CALL ABORT_TRANS('UPDSPB: Code path not (yet) supported in GPU version') ENDIF !* 1. UPDATE SPECTRAL FIELDS. ! ----------------------- #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPEC,POA,R,R_NTMAX,D,D_NUMP,D_MYMS,D_NASM0) #endif #ifdef ACCGPU !$ACC DATA PRESENT(PSPEC,POA,R,R_NTMAX,D,D_NUMP,D_MYMS,D_NASM0) ASYNC(1) #endif ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) PRIVATE(KM,IASM0,INM) & !$OMP& SHARED(D,R,KFIELD,POA,PSPEC) MAP(TO:KFIELD) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,IASM0,INM) DEFAULT(NONE) COPYIN(KFIELD) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=3,R_NTMAX+3 DO JFLD=1,KFIELD KM = D_MYMS(KMLOC) IASM0 = D_NASM0(KM) IF(KM /= 0 .AND. JN <= R_NTMAX+3-KM) THEN !(DO JN=3,R_NTMAX+3-KM) INM = IASM0+((R_NTMAX+3-JN)-KM)*2 PSPEC(JFLD,INM) = POA(2*JFLD-1,JN,KMLOC) PSPEC(JFLD,INM+1) = POA(2*JFLD ,JN,KMLOC) ELSEIF (KM == 0) THEN !(DO JN=3,R_NTMAX+3) INM = IASM0+(R_NTMAX+3-JN)*2 PSPEC(JFLD,INM) = POA(2*JFLD-1,JN,KMLOC) PSPEC(JFLD,INM+1) = 0.0_JPRBT END IF ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE UPDSPB END MODULE UPDSPB_MOD ectrans-1.8.0/src/trans/gpu/internal/dir_trans_ctlad_mod.F900000775000175000017500000001666415174631767024204 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE DIR_TRANS_CTLAD_MOD CONTAINS SUBROUTINE DIR_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANS_CTLAD* - Control routine for adjoint of the direct spectral transform. ! Purpose. ! -------- ! Control routine for the adjoint of the direct spectral transform !** Interface. ! ---------- ! CALL DIR_TRANS_CTLAD(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity ! PSPDIV(:,:) - spectral divergence ! PSPSCALAR(:,:) - spectral scalarvalued fields ! 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. ! PGP(:,:,:) - gridpoint fields ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPRBT, JPRD, JPRB, JPIM USE TPM_GEN, ONLY: NPROMATR USE TPM_TRANS, ONLY: GROWING_ALLOCATION USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, MAKE_BUFFERED_ALLOCATOR, & & INSTANTIATE_ALLOCATOR USE FTINV_MOD, ONLY: FTINV_HANDLE, PREPARE_FTINV, FTINV USE LTDIRAD_MOD, ONLY: LTDIRAD_HANDLE, PREPARE_LTDIRAD, LTDIRAD USE TRLTOG_MOD, ONLY: TRLTOG_HANDLE, PREPARE_TRLTOG, TRLTOG USE TRLTOMAD_MOD, ONLY: TRLTOMAD_HANDLE, PREPARE_TRLTOMAD, TRLTOMAD USE TRLTOMAD_PACK_UNPACK, ONLY: TRLTOMAD_PACK_HANDLE, TRLTOMAD_UNPACK_HANDLE, & & PREPARE_TRLTOMAD_PACK, PREPARE_TRLTOMAD_UNPACK, TRLTOMAD_PACK, & & TRLTOMAD_UNPACK USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) 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(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP2(:,:,:) ! Local variables REAL(KIND=JPRBT), POINTER :: FOUBUF_IN(:), FOUBUF(:) REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:), PREEL_COMPLEX(:) REAL(KIND=JPRBT), POINTER :: ZINPS(:), ZINPA(:) REAL(KIND=JPRD), POINTER :: ZINPS0(:), ZINPA0(:) TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR TYPE(TRLTOG_HANDLE) :: HTRLTOG TYPE(FTINV_HANDLE) :: HFTINV TYPE(TRLTOMAD_PACK_HANDLE) :: HTRLTOM_PACK TYPE(TRLTOMAD_HANDLE) :: HTRLTOM TYPE(TRLTOMAD_UNPACK_HANDLE) :: HTRLTOM_UNPACK TYPE(LTDIRAD_HANDLE) :: HLTDIR IF (NPROMATR > 0) THEN CALL ABORT_TRANS("NPROMATR > 0 not supported for GPU") ENDIF ! Prepare everything ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() IF (KF_FS > 0) THEN HLTDIR = PREPARE_LTDIRAD(ALLOCATOR, KF_FS, KF_UV) HTRLTOM_UNPACK = PREPARE_TRLTOMAD_UNPACK(ALLOCATOR, KF_FS) HTRLTOM = PREPARE_TRLTOMAD(ALLOCATOR, KF_FS) HTRLTOM_PACK = PREPARE_TRLTOMAD_PACK(ALLOCATOR, KF_FS) HFTINV = PREPARE_FTINV(ALLOCATOR,KF_FS) ENDIF HTRLTOG = PREPARE_TRLTOG(ALLOCATOR,KF_GP,KF_FS) CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) IF (KF_FS > 0) THEN CALL LTDIRAD(ALLOCATOR,HLTDIR,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV,KF_SCALARS, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2) CALL GSTATS(153,0) CALL TRLTOMAD_UNPACK(ALLOCATOR,HTRLTOM_UNPACK,FOUBUF,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV) CALL TRLTOMAD(ALLOCATOR,HTRLTOM,FOUBUF_IN,FOUBUF,KF_FS) CALL TRLTOMAD_PACK(ALLOCATOR,HTRLTOM_PACK,PREEL_COMPLEX,FOUBUF_IN,KF_FS) CALL GSTATS(153,1) ! fourier transform from PREEL_REAL to PREEL_COMPLEX (in-place!) CALL GSTATS(1640,0) CALL FTINV(ALLOCATOR,HFTINV,PREEL_COMPLEX,PREEL_REAL,KF_FS) CALL GSTATS(1640,1) ENDIF CALL GSTATS(158,0) CALL TRLTOG(ALLOCATOR,HTRLTOG,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) CALL GSTATS(158,1) END SUBROUTINE DIR_TRANS_CTLAD END MODULE DIR_TRANS_CTLAD_MOD ectrans-1.8.0/src/trans/gpu/internal/updspbad_mod.F900000775000175000017500000001064715174631767022645 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE UPDSPBAD_MOD CONTAINS SUBROUTINE UPDSPBAD(KFIELD,POA,PSPEC,KFLDPTR) !**** *UPDSPBAD* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update spectral arrays for a fixed zonal wave-number ! from values in POA. !** Interface. ! ---------- ! CALL UPDSPBAD(....) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFIELD - number of fields ! POA - work array ! PSPEC - spectral array ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the ! first and last field ! L. Isaksen : 95-06-06 Reordering of spectral arrays ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRBT) ,INTENT(OUT) :: POA(:,:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: KM,KMLOC INTEGER(KIND=JPIM) :: INM, IR, JFLD, JN, IASM0 ! ------------------------------------------------------------------ !* 0. NOTE. ! ----- ! The following transfer reads : ! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) ! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) ! with n from m to NSMAX ! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. ! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) ! nn is the loop index. ASSOCIATE(D_NUMP=>D%NUMP, D_MYMS=>D%MYMS, D_NASM0=>D%NASM0, R_NTMAX=>R%NTMAX) IF(PRESENT(KFLDPTR)) THEN CALL ABORT_TRANS('UPDSPB: Code path not (yet) supported in GPU version') ENDIF !* 1. UPDATE SPECTRAL FIELDS. ! ----------------------- #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPEC,POA,R,R_NTMAX,D,D_NUMP,D_MYMS,D_NASM0) #endif #ifdef ACCGPU !$ACC DATA PRESENT(PSPEC,POA,R,R_NTMAX,D,D_NUMP,D_MYMS,D_NASM0) ASYNC(1) #endif ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) PRIVATE(KM,IASM0,INM) & !$OMP& SHARED(D,R,KFIELD,POA,PSPEC) MAP(TO:KFIELD) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(KM,IASM0,INM) DEFAULT(NONE) COPYIN(KFIELD) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=3,R_NTMAX+3 DO JFLD=1,KFIELD KM = D_MYMS(KMLOC) IASM0 = D_NASM0(KM) IF(KM /= 0 .AND. JN <= R_NTMAX+3-KM) THEN !(DO JN=3,R_NTMAX+3-KM) INM = IASM0+((R_NTMAX+3-JN)-KM)*2 POA(2*JFLD-1,JN,KMLOC) = PSPEC(JFLD,INM) POA(2*JFLD ,JN,KMLOC) = PSPEC(JFLD,INM+1) ELSEIF (KM == 0) THEN !(DO JN=3,R_NTMAX+3) INM = IASM0+(R_NTMAX+3-JN)*2 POA(2*JFLD-1,JN,KMLOC) = PSPEC(JFLD,INM) POA(2*JFLD,JN,KMLOC) = 0 END IF ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE UPDSPBAD END MODULE UPDSPBAD_MOD ectrans-1.8.0/src/trans/gpu/internal/ltdir_mod.F900000775000175000017500000002554015174631767022157 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE LTDIR_MOD USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRB, JPRD, JPIB USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: PREPARE_LTDIR, LTDIR_HANDLE, LTDIR TYPE LTDIR_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HOUT_AND_POA END TYPE CONTAINS FUNCTION PREPARE_LTDIR(ALLOCATOR, KF_FS, KF_UV) RESULT(HLTDIR) USE TPM_DISTR, ONLY: D USE TPM_DIM, ONLY: R USE ISO_C_BINDING, ONLY: C_SIZEOF USE LEDIR_MOD, ONLY: LEDIR_STRIDES USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV TYPE(LTDIR_HANDLE) :: HLTDIR INTEGER(KIND=JPIB) :: IALLOC_SZ INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE REAL(KIND=JPRBT) :: ZPRBT_DUMMY REAL(KIND=JPRD) :: ZPRD_DUMMY CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE) ! POA1 IALLOC_SZ = ALIGN(2_JPIB*KF_FS*(R%NTMAX+3)*D%NUMP*C_SIZEOF(ZPRBT_DUMMY),128) ! POA2 IALLOC_SZ = IALLOC_SZ + ALIGN(4_JPIB*KF_UV*(R%NTMAX+3)*D%NUMP*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUT IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUT0 IALLOC_SZ = IALLOC_SZ+ ALIGN(IOUT0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HLTDIR%HOUT_AND_POA = RESERVE(ALLOCATOR, IALLOC_SZ, "HLTDIR%HOUT_AND_POA") END FUNCTION PREPARE_LTDIR SUBROUTINE LTDIR(ALLOCATOR,HLTDIR,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2, & & KFLDPTRUV,KFLDPTRSC) USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE TPM_GEOMETRY, ONLY: G USE PREPSNM_MOD, ONLY: PREPSNM USE LEDIR_MOD, ONLY: LEDIR_STRIDES, LEDIR USE UVTVD_MOD, ONLY: UVTVD USE UPDSP_MOD, ONLY: UPDSP USE UPDSPB_MOD, ONLY: UPDSPB USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_GEN, ONLY: LSYNC_TRANS USE TPM_TRANS, ONLY: NF_SC2, NF_SC3A, NF_SC3B USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_F_POINTER, C_LOC, C_SIZEOF !**** *LTDIR* - Control of Direct Legendre transform step ! Purpose. ! -------- ! Tranform from Fourier space to spectral space, compute ! vorticity and divergence. !** Interface. ! ---------- ! *CALL* *LTDIR(...)* ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI2 - prepares the Fourier work arrays for model variables. ! LEDIR - direct Legendre transform ! UVTVD - ! UPDSP - updating of spectral arrays (fields) ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-24 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified 94-04-06 R. El khatib Full-POS implementation ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group : 95-10-01 Support for Distributed Memory version ! K. YESSAD (AUGUST 1996): ! - Legendre transforms for transmission coefficients. ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! R. El Khatib 12-Jul-2012 LDSPC2 replaced by UVTVD ! ------------------------------------------------------------------ IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM) :: KM INTEGER(KIND=JPIM) :: KMLOC INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS 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) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRBT), POINTER, INTENT(IN) :: ZINPS(:), ZINPA(:) REAL(KIND=JPRD), POINTER, INTENT(IN) :: ZINPS0(:), ZINPA0(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IFIRST REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JPRB), POINTER :: POA1_L(:), POA1(:,:,:) REAL(KIND=JPRB), POINTER :: POA2_L(:), POA2(:,:,:) REAL(KIND=JPRB), POINTER :: PU(:,:,:), PV(:,:,:), PVOR(:,:,:), PDIV(:,:,:) REAL(KIND=JPRBT), POINTER :: ZOUT(:) REAL(KIND=JPRD), POINTER :: ZOUT0(:) TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(LTDIR_HANDLE), INTENT(IN) :: HLTDIR INTEGER(KIND=JPIB) :: IALLOC_POS, IALLOC_SZ INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM ! -------------------------------------- ! ------------------------------------------------------------------ !* 2. PREPARE WORK ARRAYS. ! -------------------- CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE) IALLOC_POS = 1 IALLOC_SZ = ALIGN(2_JPIB*KF_FS*(R%NTMAX+3)*D%NUMP*C_SIZEOF(POA1_L(1)),128) CALL ASSIGN_PTR(POA1_L, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) CALL C_F_POINTER(C_LOC(POA1_L), POA1, (/ 2*KF_FS, R%NTMAX+3, D%NUMP /)) IALLOC_POS = IALLOC_POS + IALLOC_SZ IALLOC_SZ = ALIGN(4_JPIB*KF_UV*(R%NTMAX+3)*D%NUMP*C_SIZEOF(POA2_L(1)),128) CALL ASSIGN_PTR(POA2_L, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) CALL C_F_POINTER(C_LOC(POA2_L), POA2, (/ 4*KF_UV, R%NTMAX+3, D%NUMP /)) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUT IALLOC_SZ = ALIGN(IOUT_SIZE*C_SIZEOF(ZOUT(1)),128) CALL ASSIGN_PTR(ZOUT, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUT0 IALLOC_SZ = ALIGN(IOUT0_SIZE*C_SIZEOF(ZOUT0(1)),128) CALL ASSIGN_PTR(ZOUT0, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! do the legendre transform CALL LEDIR(ALLOCATOR,ZINPS,ZINPA,ZINPS0,ZINPA0,ZOUT,ZOUT0,POA1,KF_FS) #ifdef OMPGPU !$OMP TARGET DATA MAP(FROM:PSPVOR,PSPDIV) IF(KF_UV > 0) !$OMP TARGET DATA MAP(FROM:PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$OMP TARGET DATA MAP(FROM:PSPSC2) IF(NF_SC2 > 0) !$OMP TARGET DATA MAP(FROM:PSPSC3A) IF(NF_SC3A > 0) !$OMP TARGET DATA MAP(FROM:PSPSC3B) IF(NF_SC3B > 0) #endif #ifdef ACCGPU !$ACC DATA COPYOUT(PSPVOR,PSPDIV) IF(KF_UV > 0) !$ACC DATA COPYOUT(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$ACC DATA COPYOUT(PSPSC2) IF(NF_SC2 > 0) !$ACC DATA COPYOUT(PSPSC3A) IF(NF_SC3A > 0) !$ACC DATA COPYOUT(PSPSC3B) IF(NF_SC3B > 0) #endif ! ------------------------------------------------------------------ !* 5. COMPUTE VORTICITY AND DIVERGENCE. ! --------------------------------- IF( KF_UV > 0 ) THEN ! U and V are in POA1 IFIRST = 0 PU => POA1(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV PV => POA1(IFIRST+1:IFIRST+2*KF_UV,:,:) ! Compute VOR and DIV ino POA2 IFIRST = 0 PVOR => POA2(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV PDIV => POA2(IFIRST+1:IFIRST+2*KF_UV,:,:) ! Compute vorticity and divergence CALL UVTVD(KF_UV,PU,PV,PVOR,PDIV) ! Write back. Note, if we have UV, the contract says we *must* have VOR/DIV CALL UPDSPB(KF_UV,PVOR,PSPVOR,KFLDPTRUV) CALL UPDSPB(KF_UV,PDIV,PSPDIV,KFLDPTRUV) ENDIF ! ------------------------------------------------------------------ !* 6. UPDATE SPECTRAL ARRAYS. ! ----------------------- ! this is on the host, so need to cp from device, Nils CALL UPDSP(KF_UV,KF_SCALARS,POA1,& & PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) #ifdef ACCGPU !$ACC WAIT(1) #endif IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(412,0) #ifdef OMPGPU !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif IF (LSYNC_TRANS) THEN CALL GSTATS(432,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(432,1) ENDIF CALL GSTATS(412,1) ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',1,ZHOOK_HANDLE) END SUBROUTINE LTDIR END MODULE LTDIR_MOD ectrans-1.8.0/src/trans/gpu/internal/dir_trans_ctl_mod.F900000775000175000017500000001661415174631767023672 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE DIR_TRANS_CTL_MOD CONTAINS SUBROUTINE DIR_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANS_CTL* - Control routine for direct spectral transform. ! Purpose. ! -------- ! Control routine for the direct spectral transform !** Interface. ! ---------- ! CALL DIR_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity ! PSPDIV(:,:) - spectral divergence ! PSPSCALAR(:,:) - spectral scalarvalued fields ! 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. ! PGP(:,:,:) - gridpoint fields ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPRBT, JPRD, JPRB, JPIM USE TPM_GEN, ONLY: NPROMATR USE TPM_TRANS, ONLY: GROWING_ALLOCATION USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, MAKE_BUFFERED_ALLOCATOR, & & INSTANTIATE_ALLOCATOR USE FTDIR_MOD, ONLY: FTDIR_HANDLE, PREPARE_FTDIR, FTDIR USE LTDIR_MOD, ONLY: LTDIR_HANDLE, PREPARE_LTDIR, LTDIR USE TRGTOL_MOD, ONLY: TRGTOL_HANDLE, PREPARE_TRGTOL, TRGTOL USE TRLTOM_MOD, ONLY: TRLTOM_HANDLE, PREPARE_TRLTOM, TRLTOM USE TRLTOM_PACK_UNPACK, ONLY: TRLTOM_PACK_HANDLE, TRLTOM_UNPACK_HANDLE, & & PREPARE_TRLTOM_PACK, PREPARE_TRLTOM_UNPACK, TRLTOM_PACK, & & TRLTOM_UNPACK USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS 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(:,:) 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(:) 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(:,:,:) ! Local variables REAL(KIND=JPRBT), POINTER :: FOUBUF_IN(:), FOUBUF(:) REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:), PREEL_COMPLEX(:) REAL(KIND=JPRBT), POINTER :: ZINPS(:), ZINPA(:) REAL(KIND=JPRD), POINTER :: ZINPS0(:), ZINPA0(:) TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR TYPE(TRGTOL_HANDLE) :: HTRGTOL TYPE(FTDIR_HANDLE) :: HFTDIR TYPE(TRLTOM_PACK_HANDLE) :: HTRLTOM_PACK TYPE(TRLTOM_HANDLE) :: HTRLTOM TYPE(TRLTOM_UNPACK_HANDLE) :: HTRLTOM_UNPACK TYPE(LTDIR_HANDLE) :: HLTDIR IF (NPROMATR > 0) THEN CALL ABORT_TRANS("NPROMATR > 0 not supported for GPU") ENDIF ! Prepare everything ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() HTRGTOL = PREPARE_TRGTOL(ALLOCATOR,KF_GP,KF_FS) IF (KF_FS > 0) THEN HFTDIR = PREPARE_FTDIR(ALLOCATOR,KF_FS) HTRLTOM_PACK = PREPARE_TRLTOM_PACK(ALLOCATOR, KF_FS) HTRLTOM = PREPARE_TRLTOM(ALLOCATOR, KF_FS) HTRLTOM_UNPACK = PREPARE_TRLTOM_UNPACK(ALLOCATOR, KF_FS) HLTDIR = PREPARE_LTDIR(ALLOCATOR, KF_FS, KF_UV) ENDIF CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) ! from the PGP arrays to PREEL_REAL CALL GSTATS(158,0) CALL TRGTOL(ALLOCATOR,HTRGTOL,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) CALL GSTATS(158,1) IF (KF_FS > 0) THEN ! fourier transform from PREEL_REAL to PREEL_COMPLEX (in-place!) CALL GSTATS(106,0) CALL FTDIR(ALLOCATOR,HFTDIR,PREEL_REAL,PREEL_COMPLEX,KF_FS) CALL GSTATS(106,1) CALL GSTATS(153,0) CALL TRLTOM_PACK(ALLOCATOR,HTRLTOM_PACK,PREEL_COMPLEX,FOUBUF_IN,KF_FS) CALL TRLTOM(ALLOCATOR,HTRLTOM,FOUBUF_IN,FOUBUF,KF_FS) CALL TRLTOM_UNPACK(ALLOCATOR,HTRLTOM_UNPACK,FOUBUF,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV) CALL GSTATS(153,1) CALL GSTATS(103,0) CALL LTDIR(ALLOCATOR,HLTDIR,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV,KF_SCALARS, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2) CALL GSTATS(103,1) ENDIF END SUBROUTINE DIR_TRANS_CTL END MODULE DIR_TRANS_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/gath_grid_ctl_mod.F900000775000175000017500000002003615174631767023626 0ustar alastairalastair! (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. ! MODULE GATH_GRID_CTL_MOD CONTAINS SUBROUTINE GATH_GRID_CTL(PGPG,KFGATHG,KPROMA,KTO,PGP) !**** *GATH_GRID_CTL* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Routine for gathering gridpoint array !** Interface. ! ---------- ! CALL GATH_GRID_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! PGP(:,:,:) - Local gridpoint array ! ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB USE MPL_MODULE, ONLY: MPL_ALLTOALLV, MPL_RECV, MPL_SEND, MPL_WAIT, JP_BLOCKING_STANDARD, & & JP_NON_BLOCKING_STANDARD USE TPM_GEOMETRY, ONLY: G USE TPM_DISTR, ONLY: D, MTAGDISTSP, NPRCIDS, MYPROC, NPROC USE SET2PE_MOD, ONLY: SET2PE USE EQ_REGIONS_MOD, ONLY: N_REGIONS, N_REGIONS_NS IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) REAL(KIND=JPRB) , INTENT(IN) :: PGP(:,:,:) ! Declaration of local variables REAL(KIND=JPRB) :: ZFLD(D%NGPTOTMX*KFGATHG) REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IREQ(:) INTEGER(KIND=JPIM) :: IFLDR,JFLD,ITAG,ILEN,JA,JB,ISND,JGL,JLON,ILOFF INTEGER(KIND=JPIM) :: IRCV,IOFF,ILAST,IGL1,IGL2,IGLOFF,IR INTEGER(KIND=JPIM) :: JKGLO,JROF,IEND,J,IBL,IPROC,JROC,IMYFIELDS,ILRECV INTEGER(KIND=JPIM) :: ISENDREQ(KFGATHG),ITO INTEGER(KIND=JPIM) :: ILENS(NPROC),IOFFS(NPROC),ILENR(NPROC),IOFFR(NPROC) INTEGER(KIND=JPIM) :: IFLDL,IFLDS LOGICAL :: LLSAME ! ------------------------------------------------------------------ !GATHER SPECTRAL ARRAY IF( NPROC == 1 ) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFGATHG DO JROF=1,IEND PGPG(IOFF+JROF,JFLD) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ! test if values in KTO are all the same LLSAME=.TRUE. ITO=KTO(1) DO JFLD=2,KFGATHG IF(KTO(JFLD) /= ITO) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO IFLDL=D%NGPTOTMX IF(LLSAME) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JFLD=1,KFGATHG DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+(JFLD-1)*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ILENS(:)=0 IOFFS(:)=0 ILENR(:)=0 IOFFR(:)=0 DO JFLD=1,KFGATHG ILENS(KTO(JFLD))=ILENS(KTO(JFLD))+IFLDL IF(KTO(JFLD) == MYPROC) THEN ILENR(:)=ILENR(:)+IFLDL ENDIF ENDDO DO JROC=2,NPROC IOFFR(JROC)=IOFFR(JROC-1)+ ILENR(JROC-1) IOFFS(JROC)=IOFFS(JROC-1)+ ILENS(JROC-1) ENDDO IFLDS=0 DO JROC=1,NPROC IF(ILENS(JROC) > 0) THEN DO JFLD=1,KFGATHG IF(KTO(JFLD) == JROC) THEN DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+IFLDS*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO IFLDS=IFLDS+1 ENDIF ENDDO ENDIF ENDDO ENDIF IMYFIELDS = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX*IMYFIELDS*NPROC)) ELSE ALLOCATE(ZBUF(1)) ENDIF IFLDR = 0 CALL GSTATS_BARRIER(789) CALL GSTATS(809,0) IF( LLSAME )THEN !Send ISND = KTO(1) ITAG = MTAGDISTSP+1+17 CALL MPL_SEND(ZFLD,KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(1),& &CDSTRING='GATH_GRID_CTL:') ! RECIEVE IF(KTO(1) == MYPROC) THEN IFLDR = KFGATHG DO JROC=1,NPROC ITAG = MTAGDISTSP+1+17 IRCV = JROC IOFF=IFLDL*KFGATHG*(JROC-1) CALL MPL_RECV(ZBUF(IOFF+1:IOFF+IFLDL*KFGATHG),KSOURCE=NPRCIDS(IRCV),& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILRECV,& &KTAG=ITAG,CDSTRING='GATH_GRID_CTL:') ENDDO ENDIF CALL MPL_WAIT(KREQUEST=ISENDREQ(1), & & CDSTRING='GATH_GRID_CTL: WAIT') ELSE IFLDR=IMYFIELDS ! ALLTOALLV performance is really slow when number of fields (KFGATHG) is << NPROC ! This was for IBM - and RECV/SEND alternative causes problems for large number of MPI tasks. ! IF( KFGATHG >= NPROC/8 )THEN IF( .TRUE. )THEN CALL MPL_ALLTOALLV(PSENDBUF=ZFLD,KSENDCOUNTS=ILENS,& & PRECVBUF=ZBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& & CDSTRING='GATH_GRID_CTL:') ELSE IR=0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IR=IR+NPROC ENDIF ENDDO IR=IR+KFGATHG ALLOCATE(IREQ(IR)) IR=0 ITAG = MTAGDISTSP+1+17 DO JROC=1,NPROC DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IRCV = JROC IR=IR+1 CALL MPL_RECV(ZBUF(1+IOFFR(IRCV):IOFFR(IRCV)+ILENR(IRCV)),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR),& &CDSTRING='GATH_GRID_CTL:') ENDIF ENDDO ENDDO DO JFLD=1,KFGATHG ISND = KTO(JFLD) IR=IR+1 CALL MPL_SEND(ZFLD(1+IOFFS(ISND):IOFFS(ISND)+ILENS(ISND)),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR),& &CDSTRING='GATH_GRID_CTL:') ENDDO CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & & CDSTRING='GATH_GRID_CTL: WAIT') DEALLOCATE(IREQ) ENDIF ENDIF CALL GSTATS(809,1) CALL GSTATS_BARRIER2(789) CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JA,JB,IPROC,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILEN,ILOFF,JGL,JLON,JFLD) DO JFLD=1,IFLDR DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(IPROC,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) = & & ZBUF(ILEN+JLON+(JFLD-1)*IFLDL+(IPROC-1)*IFLDL*IMYFIELDS) ENDDO ILEN = ILEN + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ! Synhronize processors ! Should not be necessary !!$ CALL GSTATS(784,0) !!$ CALL MPL_BARRIER(CDSTRING='GATH_GRID_CTL:') !!$ CALL GSTATS(784,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID_CTL END MODULE GATH_GRID_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/gath_spec_control_mod.F900000775000175000017500000001467315174631767024543 0ustar alastairalastair! (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. ! MODULE GATH_SPEC_CONTROL_MOD CONTAINS SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& & KSMAX,KSPEC2,KSPEC2_G,KPOSSP,KDIM0G,LDZA0IP) !**** *GATH_SPEC_CONTROL* - Gather global spectral array from processors ! Purpose. ! -------- ! Routine for gathering spectral array !** Interface. ! ---------- ! CALL GATH_SPEC_CONTROL(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be distributed ! KTO(:) - Processor responsible for distributing each field ! KVSET(:) - "B-Set" for each field ! PSPEC(:,:) - Local spectral array ! LDZA0IP - Set first coefficients (imaginary part) to zero ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB USE MPL_MODULE, ONLY: MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, JP_BLOCKING_STANDARD, & & JP_NON_BLOCKING_STANDARD USE TPM_DISTR, ONLY: MTAGDISTSP, NPRCIDS, NPRTRW, MYSETV, MYPROC, NPROC USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE SET2PE_MOD, ONLY: SET2PE ! IMPLICIT NONE REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2_G INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP REAL(KIND=JPRB) :: ZFLD(KSPEC2,KFGATHG) REAL(KIND=JPRB),ALLOCATABLE :: ZRECV(:,:) INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,IBSET,ILEN,JA,ISND INTEGER(KIND=JPIM) :: IRCV,ISP,ILENR,ISTA,ISTP,ISENDREQ(KFGATHG),JNM INTEGER(KIND=JPIM) :: IDIST(KSPEC2_G),IMYFIELDS LOGICAL :: LLZA0IP ! ------------------------------------------------------------------ LLZA0IP=.TRUE. IF (PRESENT (LDZA0IP)) LLZA0IP=LDZA0IP !GATHER SPECTRAL ARRAY IF( NPROC == 1 ) THEN CALL GSTATS(1644,0) IF(LDIM1_IS_FLD) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) DO JM=1,KSPEC2_G DO JFLD=1,KFGATHG PSPECG(JFLD,JM) =PSPEC(JFLD,JM) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JFLD) DO JFLD=1,KFGATHG DO JM=1,KSPEC2_G PSPECG(JM,JFLD) =PSPEC(JM,JFLD) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1644,1) ELSE IMYFIELDS = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO IF(IMYFIELDS>0) THEN ALLOCATE(ZRECV(KSPEC2_G,IMYFIELDS)) II = 0 CALL GSTATS(1804,0) DO JM=0,KSMAX DO JN=JM,KSMAX IDIST(II+1) = KDIM0G(JM)+(JN-JM)*2 IDIST(II+2) = KDIM0G(JM)+(JN-JM)*2+1 II = II+2 ENDDO ENDDO CALL GSTATS(1804,1) ENDIF CALL GSTATS_BARRIER(788) !Send CALL GSTATS(810,0) IFLDS = 0 IF(KSPEC2 > 0 )THEN DO JFLD=1,KFGATHG IBSET = KVSET(JFLD) IF( IBSET == MYSETV )THEN IFLDS = IFLDS+1 ISND = KTO(JFLD) ITAG = MTAGDISTSP+JFLD+17 IF(LDIM1_IS_FLD) THEN ZFLD(1:KSPEC2,IFLDS)=PSPEC(IFLDS,1:KSPEC2) CALL MPL_SEND(ZFLD(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& &CDSTRING='GATH_SPEC_CONTROL') ELSE CALL MPL_SEND(PSPEC(1:KSPEC2,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JFLD),& &CDSTRING='GATH_SPEC_CONTROL') ENDIF ENDIF ENDDO ENDIF ! Recieve IFLDR = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IBSET = KVSET(JFLD) IFLDR = IFLDR+1 DO JA=1,NPRTRW ILEN = KPOSSP(JA+1)-KPOSSP(JA) IF( ILEN > 0 )THEN CALL SET2PE(IRCV,0,0,JA,IBSET) ITAG = MTAGDISTSP+JFLD+17 ISTA = KPOSSP(JA) ISTP = ISTA+ILEN-1 CALL MPL_RECV(ZRECV(ISTA:ISTP,IFLDR),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & &CDSTRING='GATH_SPEC_CONTROL') IF( ILENR /= ILEN )THEN WRITE(0,'("GATH_SPEC_CONTROL: JFLD=",I4," JA=",I4," ILEN=",I10," ILENR=",I10)')& &JFLD,JA,ILEN,ILENR CALL ABORT_TRANS('GATH_SPEC_CONTROL:INVALID RECEIVE MESSAGE LENGTH') ENDIF ENDIF ENDDO ENDIF ENDDO ! Check for completion of sends IF(KSPEC2 > 0 )THEN DO JFLD=1,KFGATHG IBSET = KVSET(JFLD) IF( IBSET == MYSETV )THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(JFLD), & & CDSTRING='GATH_GRID_CTL: WAIT') ENDIF ENDDO ENDIF CALL GSTATS(810,1) CALL GSTATS_BARRIER2(788) CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JNM,II,JN,ISP) DO JFLD=1,IMYFIELDS IF(LDIM1_IS_FLD) THEN DO JNM=1,KSPEC2_G PSPECG(JFLD,JNM) = ZRECV(IDIST(JNM),JFLD) ENDDO IF (LLZA0IP) THEN II = 0 DO JN=0,KSMAX ISP = KDIM0G(0)+JN*2+1 II = II+2 PSPECG(JFLD,II) = 0.0_JPRB ENDDO ENDIF ELSE DO JNM=1,KSPEC2_G PSPECG(JNM,JFLD) = ZRECV(IDIST(JNM),JFLD) ENDDO IF (LLZA0IP) THEN II = 0 DO JN=0,KSMAX ISP = KDIM0G(0)+JN*2+1 II = II+2 PSPECG(II,JFLD) = 0.0_JPRB ENDDO ENDIF ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) IF(ALLOCATED(ZRECV)) DEALLOCATE(ZRECV) !Synchronize processors CALL GSTATS(785,0) CALL MPL_BARRIER(CDSTRING='GATH_SPEC_CONTROL:') CALL GSTATS(785,1) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE GATH_SPEC_CONTROL END MODULE GATH_SPEC_CONTROL_MOD ectrans-1.8.0/src/trans/gpu/internal/trltom_pack_unpack.F900000775000175000017500000002747115174631767024067 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRLTOM_PACK_UNPACK USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE USE PARKIND_ECTRANS, ONLY: JPIM IMPLICIT NONE PRIVATE PUBLIC :: TRLTOM_PACK_HANDLE, PREPARE_TRLTOM_PACK, TRLTOM_PACK PUBLIC :: TRLTOM_UNPACK_HANDLE, PREPARE_TRLTOM_UNPACK, TRLTOM_UNPACK TYPE TRLTOM_PACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF_IN END TYPE TYPE TRLTOM_UNPACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HINPS_AND_ZINPA END TYPE INTEGER(KIND=JPIM) :: A = 8 !Alignment CONTAINS FUNCTION PREPARE_TRLTOM_PACK(ALLOCATOR, KF_FS) RESULT(HTRLTOM_PACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE ISO_C_BINDING, ONLY: C_SIZEOF USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(TRLTOM_PACK_HANDLE) :: HTRLTOM_PACK REAL(KIND=JPRBT) :: DUMMY HTRLTOM_PACK%HFOUBUF_IN = RESERVE(ALLOCATOR, 2_JPIB*D%NLENGT0B*KF_FS*C_SIZEOF(DUMMY), "HTRLTOM_PACK%HFOUBUF_IN") END FUNCTION PREPARE_TRLTOM_PACK SUBROUTINE TRLTOM_PACK(ALLOCATOR,HTRLTOM_PACK,PREEL_COMPLEX,FOUBUF_IN,KF_FS) !**** *TRLTOM_PACK* - Copy fourier data from local array to buffer ! Purpose. ! -------- ! Routine for copying fourier data from local array to buffer !** Interface. ! ---------- ! CALL TRLTOM_PACK(...) ! Explicit arguments : PREEL - local fourier/GP array ! -------------------- KF_FS - number of fields ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! ------------------------------------------------------------------ USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D, MYSETW USE TPM_GEOMETRY, ONLY: G USE TPM_DIM, ONLY: R USE ISO_C_BINDING, ONLY: C_SIZEOF ! IMPLICIT NONE REAL(KIND=JPRBT), INTENT(IN) :: PREEL_COMPLEX(:) REAL(KIND=JPRBT), POINTER, INTENT(OUT) :: FOUBUF_IN(:) INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRLTOM_PACK_HANDLE), INTENT(IN) :: HTRLTOM_PACK INTEGER(KIND=JPIM) :: JM,JF,IGLG,OFFSET_VAR,KGL INTEGER(KIND=JPIB) :: IOFF_LAT,ISTA, NMEN_MAX REAL(KIND=JPRBT) :: SCAL ASSOCIATE(D_NSTAGTF=>D%NSTAGTF, D_NPNTGTB0=>D%NPNTGTB0, D_NPTRLS=>D%NPTRLS, & & D_NDGL_FS=>D%NDGL_FS, G_NMEN=>G%NMEN, G_NLOEN=>G%NLOEN, R_NSMAX=>R%NSMAX) CALL ASSIGN_PTR(FOUBUF_IN, GET_ALLOCATION(ALLOCATOR, HTRLTOM_PACK%HFOUBUF_IN),& & 1_JPIB, 2_JPIB*D%NLENGT0B*KF_FS*C_SIZEOF(FOUBUF_IN(1))) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:G,G_NMEN,D,D_NPNTGTB0,FOUBUF_IN,PREEL_COMPLEX,D_NSTAGTF,& !$OMP& D_NDGL_FS,G_NLOEN,R,R_NSMAX) #endif #ifdef ACCGPU !$ACC DATA PRESENT(G,G_NMEN,D,D_NPNTGTB0,FOUBUF_IN,PREEL_COMPLEX,D_NSTAGTF,D_NDGL_FS,G_NLOEN, R,R_NSMAX) ASYNC(1) #endif ! scale results and move into next transformation buffer OFFSET_VAR=D_NPTRLS(MYSETW) NMEN_MAX=MAXVAL(G_NMEN) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) PRIVATE(IGLG,IOFF_LAT,ISTA,SCAL) & !$OMP& SHARED(D,R,KF_FS,OFFSET_VAR,G,& !$OMP& PREEL_COMPLEX,FOUBUF_IN) MAP(TO:KF_FS,OFFSET_VAR) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP PRIVATE(IGLG,IOFF_LAT,ISTA,SCAL) FIRSTPRIVATE(KF_FS,OFFSET_VAR) & !$ACC& TILE(32,16,1) DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KGL=1,D_NDGL_FS DO JM=0,NMEN_MAX DO JF=1,KF_FS IGLG = OFFSET_VAR+KGL-1 IF (JM <= G_NMEN(IGLG)) THEN IOFF_LAT = KF_FS*D_NSTAGTF(KGL)+(JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) SCAL = 1._JPRBT/REAL(G_NLOEN(IGLG),JPRBT) ISTA = 2_JPIB*D_NPNTGTB0(JM,KGL)*KF_FS FOUBUF_IN(ISTA+2*JF-1) = SCAL * PREEL_COMPLEX(IOFF_LAT+2*JM+1) FOUBUF_IN(ISTA+2*JF ) = SCAL * PREEL_COMPLEX(IOFF_LAT+2*JM+2) ENDIF ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA !$ACC WAIT(1) #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END ASSOCIATE END SUBROUTINE TRLTOM_PACK FUNCTION PREPARE_TRLTOM_UNPACK(ALLOCATOR, KF_FS) RESULT(HTRLTOM_UNPACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE LEDIR_MOD, ONLY: LEDIR_STRIDES USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(TRLTOM_UNPACK_HANDLE) :: HTRLTOM_UNPACK INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE INTEGER(KIND=JPIB) :: ISIZE REAL(KIND=JPRBT) :: ZPRBT_DUMMY REAL(KIND=JPRD) :: ZPRD_DUMMY CALL LEDIR_STRIDES(KF_FS,IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) ! Check if the reuse buffer is large enough ISIZE = ALIGN(IIN_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ISIZE = ISIZE + ALIGN(IIN_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ISIZE = ISIZE + ALIGN(IIN0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) ISIZE = ISIZE + ALIGN(IIN0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HTRLTOM_UNPACK%HINPS_AND_ZINPA = RESERVE(ALLOCATOR, ISIZE, "HTRLTOM_UNPACK%HINPS_AND_ZINPA") END FUNCTION PREPARE_TRLTOM_UNPACK SUBROUTINE TRLTOM_UNPACK(ALLOCATOR,HTRLTOM_UNPACK,FOUBUF,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_FIELDS, ONLY: F USE TPM_DISTR, ONLY: D USE LEDIR_MOD, ONLY: LEDIR_STRIDES USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE REAL(KIND=JPRBT), INTENT(IN) :: FOUBUF(:) REAL(KIND=JPRBT), POINTER, INTENT(INOUT) :: ZINPS(:), ZINPA(:) REAL(KIND=JPRD), POINTER, INTENT(INOUT) :: ZINPS0(:), ZINPA0(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRLTOM_UNPACK_HANDLE), INTENT(IN) :: HTRLTOM_UNPACK REAL(KIND=JPRBT), POINTER :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE INTEGER(KIND=JPIB) :: IALLOC_POS, IALLOC_SZ INTEGER(KIND=JPIB) :: JF, OFFSET1, OFFSET2 INTEGER(KIND=JPIM) :: KM, ISL, IGLS, JGL, KMLOC REAL(KIND=JPRBT) :: PAIA, PAIS ASSOCIATE(D_NUMP=>D%NUMP, R_NDGNH=>R%NDGNH, R_NDGL=>R%NDGL, F_RW=>F%RW, F_RACTHE=>F%RACTHE, & & D_MYMS=>D%MYMS, D_NPNTGTB1=>D%NPNTGTB1, D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1, & & G_NDGLU=>G%NDGLU) CALL LEDIR_STRIDES(KF_FS,IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) IALLOC_POS=1 IALLOC_SZ = ALIGN(IIN_SIZE*C_SIZEOF(ZINPS(0)),128) CALL ASSIGN_PTR(ZINPS, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ IALLOC_SZ = ALIGN(IIN_SIZE*C_SIZEOF(ZINPA(0)),128) CALL ASSIGN_PTR(ZINPA, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ IALLOC_SZ = ALIGN(IIN0_SIZE*C_SIZEOF(ZINPS0(0)),128) CALL ASSIGN_PTR(ZINPS0, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ IALLOC_SZ = ALIGN(IIN0_SIZE*C_SIZEOF(ZINPA0(0)),128) CALL ASSIGN_PTR(ZINPA0, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:ZINPS,ZINPA,ZINPS0,ZINPA0) & !$OMP& MAP(PRESENT,ALLOC:F,F_RW,F_RACTHE) & !$OMP& MAP(PRESENT,ALLOC:D,D_MYMS,D_NUMP,R,R_NDGNH,R_NDGL,G,G_NDGLU) & !$OMP& MAP(PRESENT,ALLOC:D_NPNTGTB1,D_OFFSETS_GEMM1,FOUBUF) !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,PAIA,PAIS) & !$OMP& SHARED(D,R,KF_FS,G,FOUBUF,F,& !$OMP& IIN_STRIDES0,ZINPA,ZINPS,IIN0_STRIDES0,ZINPA0,ZINPS0,KF_UV) & !$OMP& MAP(TO:KF_FS,KF_UV,IIN_STRIDES0,IIN0_STRIDES0) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(ZINPS,ZINPA,ZINPS0,ZINPA0) & !$ACC& PRESENT(F,F_RW,F_RACTHE) & !$ACC& PRESENT(D,D_MYMS,D_NUMP,R,R_NDGNH,R_NDGL,G,G_NDGLU) & !$ACC& PRESENT(D_NPNTGTB1,D_OFFSETS_GEMM1,FOUBUF) !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,JGL,PAIA,PAIS) & !$ACC& FIRSTPRIVATE(KF_FS,KF_UV,IIN_STRIDES0,IIN0_STRIDES0) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JGL=1,R_NDGNH DO JF=1,KF_FS*2 KM = D_MYMS(KMLOC) ISL = R_NDGNH-G_NDGLU(KM)+1 IF (JGL >= ISL) THEN !(DO JGL=ISL,R_NDGNH) IGLS = R_NDGL+1-JGL OFFSET1 = 2_JPIB*D_NPNTGTB1(KMLOC,JGL )*KF_FS OFFSET2 = 2_JPIB*D_NPNTGTB1(KMLOC,IGLS)*KF_FS PAIA = FOUBUF(OFFSET1+JF)-FOUBUF(OFFSET2+JF) PAIS = FOUBUF(OFFSET1+JF)+FOUBUF(OFFSET2+JF) IF (JF <= 4*KF_UV) THEN ! Multiply in case of velocity PAIA = PAIA*REAL(F_RACTHE(JGL),JPRBT) PAIS = PAIS*REAL(F_RACTHE(JGL),JPRBT) ENDIF IF (KM /= 0) THEN ZINPA(JF+(JGL-ISL)*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC))=PAIA*REAL(F_RW(JGL),JPRBT) ZINPS(JF+(JGL-ISL)*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC))=PAIS*REAL(F_RW(JGL),JPRBT) ELSEIF (MOD(JF-1,2) == 0) THEN ! every other field is sufficient because Im(KM=0) == 0 ZINPA0((JF-1)/2+1+(JGL-1)*IIN0_STRIDES0)=PAIA*REAL(F_RW(JGL),JPRBT) ZINPS0((JF-1)/2+1+(JGL-1)*IIN0_STRIDES0)=PAIS*REAL(F_RW(JGL),JPRBT) ENDIF ENDIF ENDDO ENDDO END DO #if defined(USE_CUTLASS) && defined(USE_CUTLASS_3XTF32) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) PRIVATE(KM) & !$OMP& SHARED(D_NUMP,KF_FS,D_MYMS,G_NDGLU,D_OFFSETS_GEMM1,IIN_STRIDES0,ZINPA,ZINPS) MAP(TO:KF_FS) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(2) PRIVATE(KM,JGL) & !$ACC& FIRSTPRIVATE(KF_FS,IIN_STRIDES0) ASYNC(1) #endif DO KMLOC=1,D_NUMP DO JF=1,KF_FS*2 KM = D_MYMS(KMLOC) #ifdef ACCGPU !$ACC LOOP SEQ #endif DO JGL=G_NDGLU(KM),ALIGN(G_NDGLU(KM),A)-1 IF (KM /= 0) THEN ZINPA(JF+JGL*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC))=0.0_JPRB ZINPS(JF+JGL*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC))=0.0_JPRB ENDIF ENDDO ENDDO END DO #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif END ASSOCIATE END SUBROUTINE TRLTOM_UNPACK END MODULE TRLTOM_PACK_UNPACK ectrans-1.8.0/src/trans/gpu/internal/tpm_hicfft.F900000775000175000017500000001716715174631767022333 0ustar alastairalastair! (C) Copyright 2014- ECMWF. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TPM_HICFFT ! Author. ! ------- ! George Mozdzynski ! ! Modifications. ! -------------- ! Original October 2014 ! HICFFT abstraction for CUDA and HIP August 2023 B. Reuter USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_FLOAT, C_DOUBLE, C_LOC USE GROWING_ALLOCATOR_MOD, ONLY: GROWING_ALLOCATION_TYPE IMPLICIT NONE SAVE PRIVATE PUBLIC EXECUTE_DIR_FFT, EXECUTE_INV_FFT PUBLIC CLEAN_FFT INTERFACE EXECUTE_DIR_FFT MODULE PROCEDURE EXECUTE_DIR_FFT_FLOAT,EXECUTE_DIR_FFT_DOUBLE END INTERFACE INTERFACE EXECUTE_INV_FFT MODULE PROCEDURE EXECUTE_INV_FFT_FLOAT,EXECUTE_INV_FFT_DOUBLE END INTERFACE INTERFACE SUBROUTINE CLEAN_FFT(RESOL_ID) BIND(C, NAME="clean_fft") USE ISO_C_BINDING INTEGER(KIND=C_INT), INTENT(IN), VALUE :: RESOL_ID END SUBROUTINE END INTERFACE ! ------------------------------------------------------------------ CONTAINS ! ------------------------------------------------------------------ SUBROUTINE EXECUTE_DIR_FFT_FLOAT(PREEL_REAL,PREEL_COMPLEX,RESOL_ID,KFIELD,LOENS,OFFSETS,ALLOC) USE EC_PARKIND ,ONLY : JPIM, JPIB IMPLICIT NONE REAL(KIND=C_FLOAT), POINTER, INTENT(IN) :: PREEL_REAL(:) REAL(KIND=C_FLOAT), POINTER, INTENT(OUT) :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM),INTENT(IN) :: RESOL_ID INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:) INTEGER(KIND=JPIB),INTENT(IN) :: OFFSETS(:) TYPE(GROWING_ALLOCATION_TYPE), INTENT(IN), POINTER :: ALLOC INTERFACE SUBROUTINE EXECUTE_DIR_FFT_FLOAT_C(PREEL_REAL,PREEL_COMPLEX,RESOL_ID,KFIELD,LOENS,OFFSETS,NFFT,ALLOC) & & BIND(C, NAME="execute_dir_fft_float") USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_PTR, C_INT64_T TYPE(C_PTR), VALUE :: PREEL_REAL TYPE(C_PTR), VALUE :: PREEL_COMPLEX INTEGER(KIND=C_INT),INTENT(IN),VALUE :: RESOL_ID INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(*) INTEGER(KIND=C_INT64_T),INTENT(IN) :: OFFSETS(*) INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE END INTERFACE #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(PREEL_REAL,PREEL_COMPLEX) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PREEL_REAL,PREEL_COMPLEX) #endif CALL EXECUTE_DIR_FFT_FLOAT_C(C_LOC(PREEL_REAL),C_LOC(PREEL_COMPLEX),RESOL_ID,KFIELD,LOENS,OFFSETS,SIZE(LOENS),C_LOC(ALLOC)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END SUBROUTINE EXECUTE_DIR_FFT_FLOAT SUBROUTINE EXECUTE_DIR_FFT_DOUBLE(PREEL_REAL,PREEL_COMPLEX,RESOL_ID,KFIELD,LOENS,OFFSETS,ALLOC) USE EC_PARKIND ,ONLY : JPIM, JPIB IMPLICIT NONE REAL(KIND=C_DOUBLE), POINTER, INTENT(IN) :: PREEL_REAL(:) REAL(KIND=C_DOUBLE), POINTER, INTENT(OUT) :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM),INTENT(IN) :: RESOL_ID INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:) INTEGER(KIND=JPIB),INTENT(IN) :: OFFSETS(:) TYPE(GROWING_ALLOCATION_TYPE), INTENT(IN), POINTER :: ALLOC INTERFACE SUBROUTINE EXECUTE_DIR_FFT_DOUBLE_C(PREEL_REAL,PREEL_COMPLEX,RESOL_ID,KFIELD,LOENS,OFFSETS,NFFT,ALLOC) & & BIND(C, NAME="execute_dir_fft_double") USE ISO_C_BINDING, ONLY: C_DOUBLE, C_INT, C_PTR, C_INT64_T TYPE(C_PTR), VALUE :: PREEL_REAL TYPE(C_PTR), VALUE :: PREEL_COMPLEX INTEGER(KIND=C_INT),INTENT(IN),VALUE :: RESOL_ID INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(*) INTEGER(KIND=C_INT64_T),INTENT(IN) :: OFFSETS(*) INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE END INTERFACE #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(PREEL_REAL,PREEL_COMPLEX) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PREEL_REAL,PREEL_COMPLEX) #endif CALL EXECUTE_DIR_FFT_DOUBLE_C(C_LOC(PREEL_REAL),C_LOC(PREEL_COMPLEX),RESOL_ID,KFIELD,LOENS,OFFSETS,SIZE(LOENS),C_LOC(ALLOC)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END SUBROUTINE EXECUTE_DIR_FFT_DOUBLE SUBROUTINE EXECUTE_INV_FFT_FLOAT(PREEL_COMPLEX,PREEL_REAL,RESOL_ID,KFIELD,LOENS,OFFSETS,ALLOC) USE EC_PARKIND ,ONLY : JPIM, JPIB IMPLICIT NONE REAL(KIND=C_FLOAT), POINTER, INTENT(IN) :: PREEL_COMPLEX(:) REAL(KIND=C_FLOAT), POINTER, INTENT(OUT) :: PREEL_REAL(:) INTEGER(KIND=JPIM),INTENT(IN) :: RESOL_ID INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:) INTEGER(KIND=JPIB),INTENT(IN) :: OFFSETS(:) TYPE(GROWING_ALLOCATION_TYPE), INTENT(IN), POINTER :: ALLOC INTERFACE SUBROUTINE EXECUTE_INV_FFT_FLOAT_C(PREEL_COMPLEX,PREEL_REAL,RESOL_ID,KFIELD,LOENS,OFFSETS,NFFT,ALLOC) & & BIND(C, NAME="execute_inv_fft_float") USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_PTR, C_INT64_T TYPE(C_PTR), VALUE :: PREEL_COMPLEX TYPE(C_PTR), VALUE :: PREEL_REAL INTEGER(KIND=C_INT),INTENT(IN),VALUE :: RESOL_ID INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(*) INTEGER(KIND=C_INT64_T),INTENT(IN) :: OFFSETS(*) INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE END INTERFACE #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(PREEL_COMPLEX,PREEL_REAL) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PREEL_COMPLEX,PREEL_REAL) #endif CALL EXECUTE_INV_FFT_FLOAT_C(C_LOC(PREEL_COMPLEX),C_LOC(PREEL_REAL),RESOL_ID,KFIELD,LOENS,OFFSETS,SIZE(LOENS),C_LOC(ALLOC)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END SUBROUTINE SUBROUTINE EXECUTE_INV_FFT_DOUBLE(PREEL_COMPLEX,PREEL_REAL,RESOL_ID,KFIELD,LOENS,OFFSETS,ALLOC) USE EC_PARKIND ,ONLY : JPIM, JPIB IMPLICIT NONE REAL(KIND=C_DOUBLE), POINTER, INTENT(IN) :: PREEL_COMPLEX(:) REAL(KIND=C_DOUBLE), POINTER, INTENT(OUT) :: PREEL_REAL(:) INTEGER(KIND=JPIM),INTENT(IN) :: RESOL_ID INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD INTEGER(KIND=JPIM),INTENT(IN) :: LOENS(:) INTEGER(KIND=JPIB),INTENT(IN) :: OFFSETS(:) TYPE(GROWING_ALLOCATION_TYPE), INTENT(IN), POINTER :: ALLOC INTERFACE SUBROUTINE EXECUTE_INV_FFT_DOUBLE_C(PREEL_COMPLEX,PREEL_REAL,RESOL_ID,KFIELD,LOENS,OFFSETS,NFFT,ALLOC) & & BIND(C, NAME="execute_inv_fft_double") USE ISO_C_BINDING, ONLY: C_DOUBLE, C_INT, C_PTR, C_INT64_T TYPE(C_PTR), VALUE :: PREEL_COMPLEX TYPE(C_PTR), VALUE :: PREEL_REAL INTEGER(KIND=C_INT),INTENT(IN),VALUE :: RESOL_ID INTEGER(KIND=C_INT),INTENT(IN),VALUE :: KFIELD INTEGER(KIND=C_INT),INTENT(IN) :: LOENS(*) INTEGER(KIND=C_INT64_T),INTENT(IN) :: OFFSETS(*) INTEGER(KIND=C_INT),INTENT(IN),VALUE :: NFFT TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE END INTERFACE #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(PREEL_COMPLEX,PREEL_REAL) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PREEL_COMPLEX,PREEL_REAL) #endif CALL EXECUTE_INV_FFT_DOUBLE_C(C_LOC(PREEL_COMPLEX),C_LOC(PREEL_REAL),RESOL_ID,KFIELD,LOENS,OFFSETS,SIZE(LOENS),C_LOC(ALLOC)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END SUBROUTINE END MODULE TPM_HICFFT ectrans-1.8.0/src/trans/gpu/internal/fsc_mod.F900000775000175000017500000002443215174631767021613 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE FSC_MOD USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D IMPLICIT NONE PRIVATE PUBLIC :: FSC CONTAINS SUBROUTINE FSC(PREEL_COMPLEX, KF_FS, KF_UV, KF_SCALARS, KUV_OFFSET, & & KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET, KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET) !**** *FSC - Division by a*cos(theta), east-west derivatives ! Purpose. ! -------- ! In Fourier space divide u and v and all north-south ! derivatives by a*cos(theta). Also compute east-west derivatives ! of u,v,thermodynamic, passiv scalar variables and surface ! pressure. !** Interface. ! ---------- ! CALL FSC(..) ! Explicit arguments : KF_FS - total stride ! -------------------- KF_UV - # uv layers ! KF_SCALARS - # scalar layers ! *_OFFSET - offset of the respective layer ! ! Method. ! ------- ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 (From SC2FSC) ! ------------------------------------------------------------------ USE TPM_DISTR, ONLY: MYSETW, MYPROC, NPROC, D USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS, ONLY: F USE TPM_DIM, ONLY: R ! IMPLICIT NONE REAL(KIND=JPRBT), INTENT(INOUT) :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV, KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KUV_OFFSET, KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET INTEGER(KIND=JPIM), INTENT(IN) :: KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET INTEGER(KIND=JPIM) :: KGL REAL(KIND=JPRBT) :: ZACHTE2 INTEGER(KIND=JPIM) :: OFFSET_VAR,ILOEN_MAX INTEGER(KIND=JPIB) :: IOFF_LAT INTEGER(KIND=JPIB) :: IOFF_SCALARS,IOFF_SCALARS_EWDER,IOFF_UV,IOFF_UV_EWDER,IOFF_KSCALARS_NSDER INTEGER(KIND=JPIM) :: JF,IGLG,JM INTEGER(KIND=JPIM) :: IBEG,IEND,IINC REAL(KIND=JPRBT) :: RET_REAL, RET_COMPLEX ASSOCIATE(D_NUMP=>D%NUMP, D_NPTRLS=>D%NPTRLS, D_NSTAGTF=>D%NSTAGTF, G_NMEN=>G%NMEN, & & G_NLOEN=>G%NLOEN, F_RACTHE=>F%RACTHE, R_NSMAX=>R%NSMAX) ! ------------------------------------------------------------------ IF(MYPROC > NPROC/2)THEN IBEG=1 IEND=D%NDGL_FS IINC=1 ELSE IBEG=D%NDGL_FS IEND=1 IINC=-1 ENDIF #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:D,D_NPTRLS,D_NSTAGTF,PREEL_COMPLEX,F,F_RACTHE,G,G_NMEN,G_NLOEN,R,R_NSMAX) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(D,D_NPTRLS,D_NSTAGTF,PREEL_COMPLEX,F,F_RACTHE,G,G_NMEN,G_NLOEN,R,R_NSMAX) #endif ! ------------------------------------------------------------------ !* 1. DIVIDE U V AND N-S DERIVATIVES BY A*COS(THETA) ! ---------------------------------------------- OFFSET_VAR=D%NPTRLS(MYSETW) !* 1.1 U AND V. #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_UV,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_UV,R,OFFSET_VAR,G,D,KF_FS,KUV_OFFSET,F,PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_UV,OFFSET_VAR,KF_FS,KUV_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) & !$ACC& PRIVATE(IGLG,IOFF_LAT,IOFF_UV,ZACHTE2,JM,JF,KGL) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,OFFSET_VAR,KF_UV,KUV_OFFSET,KF_FS) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,2*KF_UV DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) IGLG = OFFSET_VAR+KGL-1 IF (JM <= G_NMEN(IGLG)) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_UV = IOFF_LAT+(KUV_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) PREEL_COMPLEX(IOFF_UV+2*JM+1) = & & PREEL_COMPLEX(IOFF_UV+2*JM+1)*ZACHTE2 PREEL_COMPLEX(IOFF_UV+2*JM+2) = & & PREEL_COMPLEX(IOFF_UV+2*JM+2)*ZACHTE2 ENDIF ENDDO ENDDO ENDDO !* 1.2 N-S DERIVATIVES IF (KSCALARS_NSDER_OFFSET >= 0) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_KSCALARS_NSDER,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_SCALARS,R,OFFSET_VAR,G,D,KF_FS,KSCALARS_NSDER_OFFSET,F,& !$OMP& PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_SCALARS,OFFSET_VAR,KF_FS,KSCALARS_NSDER_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IGLG,IOFF_LAT,IOFF_KSCALARS_NSDER,ZACHTE2,KGL,JF,JM) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,OFFSET_VAR,KF_SCALARS,KSCALARS_NSDER_OFFSET,KF_FS) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,KF_SCALARS DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) IGLG = OFFSET_VAR+KGL-1 IF (JM <= G_NMEN(IGLG)) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_KSCALARS_NSDER = IOFF_LAT+(KSCALARS_NSDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+1) = & & PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+1)*ZACHTE2 PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+2) = & & PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+2)*ZACHTE2 ENDIF ENDDO ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ !* 2. EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. ILOEN_MAX = MAXVAL(G_NLOEN) IF (KUV_EWDER_OFFSET >= 0) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_UV,IOFF_UV_EWDER,RET_REAL,RET_COMPLEX,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_UV,ILOEN_MAX,OFFSET_VAR,G,D,KF_FS,KUV_OFFSET,KUV_EWDER_OFFSET,F,& !$OMP& PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_UV,ILOEN_MAX,OFFSET_VAR,KF_FS,KUV_OFFSET,KUV_EWDER_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IGLG,IOFF_LAT,IOFF_UV,IOFF_UV_EWDER,RET_REAL,RET_COMPLEX,ZACHTE2,JM,JF,KGL) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,OFFSET_VAR,KF_UV,KUV_EWDER_OFFSET,KUV_OFFSET,KF_FS,ILOEN_MAX) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,2*KF_UV DO JM=0,ILOEN_MAX/2 IGLG = OFFSET_VAR+KGL-1 ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have ! to fill those floor(NLON/2)+1 values. ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. IF (JM <= G_NLOEN(IGLG)/2) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_UV = IOFF_LAT+(KUV_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) IOFF_UV_EWDER = IOFF_LAT+(KUV_EWDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) RET_REAL = 0.0_JPRBT RET_COMPLEX = 0.0_JPRBT IF (JM <= G_NMEN(IGLG)) THEN ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) RET_REAL = & & -PREEL_COMPLEX(IOFF_UV+2*JM+2)*ZACHTE2*REAL(JM,JPRBT) RET_COMPLEX = & & PREEL_COMPLEX(IOFF_UV+2*JM+1)*ZACHTE2*REAL(JM,JPRBT) ENDIF PREEL_COMPLEX(IOFF_UV_EWDER+2*JM+1) = RET_REAL PREEL_COMPLEX(IOFF_UV_EWDER+2*JM+2) = RET_COMPLEX ENDIF ENDDO ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES IF (KSCALARS_EWDER_OFFSET > 0) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_SCALARS_EWDER,IOFF_SCALARS,RET_REAL,RET_COMPLEX,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_SCALARS,ILOEN_MAX,OFFSET_VAR,G,D,KF_FS,KSCALARS_EWDER_OFFSET,& !$OMP& KSCALARS_OFFSET,F,PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_SCALARS,ILOEN_MAX,OFFSET_VAR,KF_FS,KSCALARS_EWDER_OFFSET,& !$OMP& KSCALARS_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IGLG,IOFF_LAT,IOFF_SCALARS_EWDER,IOFF_SCALARS,ZACHTE2,RET_REAL,RET_COMPLEX) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,KF_SCALARS,OFFSET_VAR,KSCALARS_EWDER_OFFSET,KSCALARS_OFFSET,KF_FS,ILOEN_MAX) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,KF_SCALARS DO JM=0,ILOEN_MAX/2 IGLG = OFFSET_VAR+KGL-1 ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have ! to fill those floor(NLON/2)+1 values. ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. IF (JM <= G_NLOEN(IGLG)/2) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_SCALARS_EWDER = IOFF_LAT+(KSCALARS_EWDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) IOFF_SCALARS = IOFF_LAT+(KSCALARS_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) RET_REAL = 0.0_JPRBT RET_COMPLEX = 0.0_JPRBT IF (JM <= G_NMEN(IGLG)) THEN ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) RET_REAL = & & -PREEL_COMPLEX(IOFF_SCALARS+2*JM+2)*ZACHTE2*REAL(JM,JPRBT) RET_COMPLEX = & & PREEL_COMPLEX(IOFF_SCALARS+2*JM+1)*ZACHTE2*REAL(JM,JPRBT) ENDIF ! The rest from G_NMEN(IGLG+1)...MAX is zero truncated PREEL_COMPLEX(IOFF_SCALARS_EWDER+2*JM+1) = RET_REAL PREEL_COMPLEX(IOFF_SCALARS_EWDER+2*JM+2) = RET_COMPLEX ENDIF ENDDO ENDDO ENDDO ENDIF #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE FSC END MODULE FSC_MOD ectrans-1.8.0/src/trans/gpu/internal/ftdir_mod.F900000775000175000017500000001114615174631767022146 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE FTDIR_MOD USE BUFFERED_ALLOCATOR_MOD ,ONLY : ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: FTDIR, FTDIR_HANDLE, PREPARE_FTDIR TYPE FTDIR_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HREEL_COMPLEX END TYPE CONTAINS FUNCTION PREPARE_FTDIR(ALLOCATOR,KF_FS) RESULT(HFTDIR) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(FTDIR_HANDLE) :: HFTDIR REAL(KIND=JPRBT) :: DUMMY #ifndef IN_PLACE_FFT HFTDIR%HREEL_COMPLEX = RESERVE(ALLOCATOR, 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(DUMMY), "HFTDIR%HREEL_COMPLEX") #endif END FUNCTION PREPARE_FTDIR SUBROUTINE FTDIR(ALLOCATOR,HFTDIR,PREEL_REAL,PREEL_COMPLEX,KFIELD) !**** *FTDIR - Direct Fourier transform ! Purpose. Routine for Grid-point to Fourier transform ! -------- !** Interface. ! ---------- ! CALL FTDIR(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELD - number of fields ! Method. ! ------- ! Externals. FFT992 - FFT routine ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti 01-04-24 2D model (NLOEN=1) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW ! ------------------------------------------------------------------ USE TPM_GEN, ONLY: LSYNC_TRANS, NCUR_RESOL USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: MYSETW, NPROC, D USE TPM_GEOMETRY, ONLY: G USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_HICFFT, ONLY: EXECUTE_DIR_FFT USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRBT), INTENT(INOUT), POINTER :: PREEL_REAL(:) REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PREEL_COMPLEX(:) TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(FTDIR_HANDLE) :: HFTDIR INTEGER(KIND=JPIM) :: KGL #ifdef IN_PLACE_FFT PREEL_COMPLEX => PREEL_REAL #else CALL ASSIGN_PTR(PREEL_COMPLEX, GET_ALLOCATION(ALLOCATOR, HFTDIR%HREEL_COMPLEX),& & 1_JPIB, 1_JPIB*KFIELD*D%NLENGTF*C_SIZEOF(PREEL_COMPLEX(1))) #endif ASSOCIATE(D_NDGL_FS=>D%NDGL_FS, D_NSTAGT0B=>D%NSTAGT0B, D_NSTAGTF=>D%NSTAGTF, & & D_NPTRLS=>D%NPTRLS, D_NPNTGTB0=>D%NPNTGTB0, D_NPROCM=>D%NPROCM, & & G_NMEN=>G%NMEN, G_NLOEN=>G%NLOEN) #ifdef ACCGPU !$ACC DATA PRESENT(PREEL_REAL, PREEL_COMPLEX, & !$ACC& D_NSTAGTF,D_NSTAGT0B,D_NPTRLS,D_NPROCM,D_NPNTGTB0,G_NMEN,G_NLOEN) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PREEL_COMPLEX, & !$OMP& D_NSTAGTF,D_NSTAGT0B,D_NPTRLS,D_NPROCM,D_NPNTGTB0,G_NMEN,G_NLOEN) #endif IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(413,0) CALL EXECUTE_DIR_FFT(PREEL_REAL,PREEL_COMPLEX,NCUR_RESOL,KFIELD, & & LOENS=G_NLOEN(D_NPTRLS(MYSETW):D_NPTRLS(MYSETW)+D_NDGL_FS-1), & & OFFSETS=D_NSTAGTF(1:D_NDGL_FS+1),ALLOC=ALLOCATOR%PTR) IF (LSYNC_TRANS) THEN CALL GSTATS(433,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(433,1) ENDIF CALL GSTATS(413,1) #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif NULLIFY(PREEL_REAL) END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE FTDIR END MODULE FTDIR_MOD ectrans-1.8.0/src/trans/gpu/internal/vdtuvad_mod.F900000775000175000017500000001264415174631767022517 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE VDTUVAD_MOD CONTAINS SUBROUTINE VDTUVAD(KFIELD,PEPSNM,PVOR,PDIV,PU,PV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_FIELDS, ONLY: F USE TPM_DISTR, ONLY: D !**** *VDTUVAD* - Adjoint of "Compute U,V in spectral space" ! Purpose. ! -------- ! In Laplace space compute the the winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL VDTUV(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PVOR(NLEI1,2*KFIELD) - vorticity (input) ! PDIV(NLEI1,2*KFIELD) - divergence (input) ! PU(NLEI1,2*KFIELD) - u wind (output) ! PV(NLEI1,2*KFIELD) - v wind (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUV in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) :: KM, kmloc INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(1:D%NUMP,0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(INOUT) :: PVOR(:,:,:),PDIV(:,:,:) REAL(KIND=JPRB), INTENT(IN) :: PU (:,:,:),PV (:,:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IR, J, JN, JI ! LOCAL REAL SCALARS REAL(KIND=JPRBT) :: ZKM ASSOCIATE(D_NUMP=>D%NUMP, D_MYMS=>D%MYMS, R_NTMAX=>R%NTMAX, F_RLAPIN=>F%RLAPIN) #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(R,R_NTMAX,D,D_MYMS,D_NUMP,F,F_RLAPIN) & !$ACC& PRESENT(PEPSNM, PVOR, PDIV) & !$ACC& PRESENT(PU, PV) #endif #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:R,R_NTMAX,D,D_MYMS,D_NUMP,F,F_RLAPIN) & !$OMP& MAP(PRESENT,ALLOC:PEPSNM, PVOR, PDIV) & !$OMP& MAP(PRESENT,ALLOC:PU, PV) #endif ! ------------------------------------------------------------------ !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IR,II,KM,ZKM,JI) SHARED(D,R,F,PEPSNM,PVOR,PDIV,PU,PV,KFIELD) & !$OMP& MAP(TO:KFIELD) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IR,II,KM,ZKM,JI) FIRSTPRIVATE(KFIELD,KMLOC) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=0,R_NTMAX+1 DO J=1,KFIELD IR = 2*J-1 II = IR+1 KM = D_MYMS(KMLOC) ZKM = REAL(KM,JPRBT) JI = R_NTMAX+3-JN IF(KM /= 0 .AND. JN >= KM) THEN ! (DO JN=KN,R_NTMAX) PDIV(II,JI,KMLOC) = -(JN)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN)*PV(II,JI-1,KMLOC) - & & ZKM*F_RLAPIN(JN)*PU(IR,JI,KMLOC) + & & (JN+1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN)*PV(II,JI+1,KMLOC) PDIV(IR,JI,KMLOC) = -(JN)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN)*PV(IR,JI-1,KMLOC) + & & ZKM*F_RLAPIN(JN)*PU(II,JI,KMLOC) + & & (JN+1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN)*PV(IR,JI+1,KMLOC) PVOR(II,JI,KMLOC) = +(JN)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN)*PU(II,JI-1,KMLOC) - & & ZKM*F_RLAPIN(JN)*PV(IR,JI,KMLOC) - & & (JN+1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN)*PU(II,JI+1,KMLOC) PVOR(IR,JI,KMLOC) = +(JN)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN)*PU(IR,JI-1,KMLOC) + & & ZKM*F_RLAPIN(JN)*PV(II,JI,KMLOC) - & & (JN+1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN)*PU(IR,JI+1,KMLOC) ELSEIF(KM == 0) THEN ! (DO JN=0,R_NTMAX) PVOR(II,JI,KMLOC) = 0.0_JPRB PVOR(IR,JI,KMLOC) = +(JN)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN)*PU(IR,JI-1,KMLOC) - & & (JN+1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN)*PU(IR,JI+1,KMLOC) PDIV(II,JI,KMLOC) = 0.0_JPRB PDIV(IR,JI,KMLOC) = -(JN)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN)*PV(IR,JI-1,KMLOC) + & & (JN+1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN)*PV(IR,JI+1,KMLOC) ENDIF ENDDO ENDDO ENDDO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE VDTUVAD END MODULE VDTUVAD_MOD ectrans-1.8.0/src/trans/gpu/internal/prepsnm_mod.F900000775000175000017500000000466515174631767022532 0ustar alastairalastair! (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. ! MODULE PREPSNM_MOD CONTAINS SUBROUTINE PREPSNM !**** *PREPSNM* - Prepare REPSNM for wavenumber KM ! Purpose. ! -------- ! Copy the REPSNM values for specific zonal wavenumber M ! to work array !** Interface. ! ---------- ! CALL PREPSNM(...) ! Explicit arguments : KM - zonal wavenumber ! ------------------- KMLOC - local zonal wavenumber ! PEPSNM - REPSNM for zonal ! wavenumber KM ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Reference. ! ---------- ! Author. ! ------- ! Lars Isaksen *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINV in IFS CY22R1 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT USE TPM_DIM, ONLY: R USE TPM_FIELDS, ONLY: F USE TPM_FIELDS_GPU, ONLY: FG USE TPM_DISTR, ONLY: D ! IMPLICIT NONE INTEGER(KIND=JPIM) :: KM,KMLOC !!REAL(KIND=JPRB), INTENT(INOUT) :: PEPSNM(:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: JN INTEGER(KIND=JPIM) :: R_NTMAX ! ------------------------------------------------------------------ !* 1. COPY REPSNM. ! ------------ !!!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO !!!$ACC parallel loop DO KMLOC=1,D%NUMP KM = D%MYMS(KMLOC) IF (KM > 0) THEN #ifdef ACCGPU !$ACC loop #endif DO JN=0,KM-1 FG%ZEPSNM(KMLOC,JN) = 0.0_JPRBT ENDDO ENDIF DO JN=KM,R%NTMAX+2 FG%ZEPSNM(KMLOC,JN) = REAL(F%REPSNM(D%NPMT(KM)+KMLOC-KM+JN),JPRBT) ENDDO ! end loop over wavenumber ENDDO !!!!$OMP END TARGET DATA !!!!$ACC end data ! ------------------------------------------------------------------ END SUBROUTINE PREPSNM END MODULE PREPSNM_MOD ectrans-1.8.0/src/trans/gpu/internal/read_legpol_mod.F900000775000175000017500000001601415174631767023312 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE READ_LEGPOL_MOD CONTAINS SUBROUTINE READ_LEGPOL USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT USE TPM_GEN, ONLY: NERR USE TPM_DISTR, ONLY: D, NPRTRV USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE TPM_FLT, ONLY: S USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE TPM_CTL, ONLY: C USE BYTES_IO_MOD, ONLY: BYTES_IO_READ, JPBYTES_IO_SUCCESS, BYTES_IO_CLOSE, BYTES_IO_OPEN USE SHAREDMEM_MOD, ONLY: SHAREDMEM_ASSOCIATE !**** *READ_LEGPOL * - read in Leg.Pol. and assocciated arrays from file or memory segment ! Purpose. ! -------- ! !** Interface. ! ---------- ! *CALL* *READ_LEGPOL* ! Explicit arguments : None ! -------------------- ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! ! ------- ! Mats Hamrud and Willem Deconinck *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 IMPLICIT NONE INTEGER(KIND=JPIM),PARAMETER :: JPIBUFL=4 INTEGER(KIND=JPIM) :: IRBYTES,IIBYTES,JMLOC,IPRTRV,IMLOC,IM,ILA,ILS INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IFILE,JSETV,JGL,II,IDGLU2 INTEGER(KIND=JPIM),POINTER :: IBUF(:) REAL(KIND=JPRBT) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,POINTER :: IBUFA(:) CHARACTER(LEN=8) :: CLABEL CHARACTER(LEN=16) :: CLABEL_16 ! ------------------------------------------------------------------ IRBYTES = 8 IIBYTES = 4 IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_OPEN(IFILE,C%CLEGPOLFNAME,'R') ALLOCATE(IBUF(JPIBUFL)) ELSE NULLIFY(IBUF) ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF CLABEL = TRANSFER(IBUF(1:2),CLABEL) IF(CLABEL /= 'LEGPOL ') THEN WRITE(NERR,*) CLABEL CALL ABORT_TRANS('READ_LEGPOL:WRONG LABEL') ENDIF IF(IBUF(3) /= R%NSMAX) CALL ABORT_TRANS('READ_LEGPOL:WRONG SPECTRAL TRUNCATION') IF(IBUF(4) /= R%NDGNH) CALL ABORT_TRANS('READ_LEGPOL:WRONG NO OF GAUSSIAN LATITUDES') IF(C%CIO_TYPE == 'file') THEN ALLOCATE(IBUFA(2*R%NDGNH)) CALL BYTES_IO_READ(IFILE,IBUFA,2*R%NDGNH*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*R%NDGNH,IBUFA,ADVANCE=.TRUE.) ENDIF II = 0 DO JGL=1,R%NDGNH II = II+1 IF(IBUFA(II) /= G%NLOEN(JGL)) THEN WRITE(NERR,*) 'WRONG NUMBER OF LONGITUDE POINTS ', JGL,G%NLOEN(JGL),IBUFA(II) CALL ABORT_TRANS('READ_LEGPOL:WRONG NLOEN') ENDIF II=II+1 IF(IBUFA(II) /= G%NMEN(JGL)) THEN WRITE(NERR,*) 'WRONG CUT-OFF WAVE NUMBER ', JGL,G%NMEN(JGL),IBUFA(II) CALL ABORT_TRANS('READ_LEGPOL:WRONG NMEN') ENDIF ENDDO IF(C%CIO_TYPE == 'file') THEN DEALLOCATE(IBUFA) ENDIF DO JMLOC=1,D%NUMP,NPRTRV ! +++++++++++++++++++++ JMLOC LOOP ++++++++++ IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ! Anti-symmetric IF(C%CIO_TYPE == 'file') THEN ISIZE = IDGLU*ILA ALLOCATE(ZBUF(ISIZE)) IBYTES = ISIZE*IRBYTES CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(IMLOC)%RPNMA(IDGLU,ILA)) S%FA(IMLOC)%RPNMA(:,:) = RESHAPE(ZBUF,(/IDGLU,ILA/)) DEALLOCATE(ZBUF) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,IDGLU,ILA,S%FA(IMLOC)%RPNMA,ADVANCE=.TRUE.) ENDIF ! Symmetric IF(C%CIO_TYPE == 'file') THEN ISIZE = IDGLU*ILS IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(IMLOC)%RPNMS(IDGLU,ILS)) S%FA(IMLOC)%RPNMS(:,:) = RESHAPE(ZBUF,(/IDGLU,ILS/)) DEALLOCATE(ZBUF) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,IDGLU,ILS,S%FA(IMLOC)%RPNMS,ADVANCE=.TRUE.) ENDIF ENDDO ENDDO ! Lat-lon grid IF(S%LDLL) THEN IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF CLABEL_16 = TRANSFER(IBUF,CLABEL_16) IF(CLABEL_16 /= 'LATLON---BEG-BEG')CALL ABORT_TRANS('READ_LEGPOL:WRONG LAT/LON LABEL') DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IDGLU2 = S%NDGNHD IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF IF(IBUF(1) /= IM .OR. IBUF(2) /= IDGLU .OR. IBUF(3) /= IDGLU2 ) THEN WRITE(NERR,*) 'READ_LEGPOL ERROR ', IBUF,IM,IDGLU,IDGLU2 CALL ABORT_TRANS('READ_LEGPOL:WRONG LAT-LON MATRIX SIZE') ENDIF IF(C%CIO_TYPE == 'file') THEN ISIZE = 2*IDGLU*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(JMLOC)%RPNMWI(2*IDGLU,2)) S%FA(JMLOC)%RPNMWI(:,:) = RESHAPE(ZBUF,(/2*IDGLU,2/)) DEALLOCATE(ZBUF) ISIZE = 2*IDGLU2*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(JMLOC)%RPNMWO(2*IDGLU2,2)) S%FA(JMLOC)%RPNMWO(:,:) = RESHAPE(ZBUF,(/2*IDGLU2,2/)) DEALLOCATE(ZBUF) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*IDGLU,2,S%FA(JMLOC)%RPNMWI,ADVANCE=.TRUE.) CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*IDGLU2,2,S%FA(JMLOC)%RPNMWO,ADVANCE=.TRUE.) ENDIF ENDDO ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF CLABEL_16 = TRANSFER(IBUF,CLABEL_16) IF(CLABEL_16 /= 'LEGPOL---EOF-EOF')CALL ABORT_TRANS('READ_LEGPOL:WRONG END LABEL') IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_CLOSE(IFILE) DEALLOCATE(IBUF) ENDIF END SUBROUTINE READ_LEGPOL END MODULE READ_LEGPOL_MOD ectrans-1.8.0/src/trans/gpu/internal/dist_spec_control_mod.F900000775000175000017500000001414615174631767024556 0ustar alastairalastair! (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. ! MODULE DIST_SPEC_CONTROL_MOD CONTAINS SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& & KSMAX,KSPEC2,KSPEC2_G,KPOSSP,KDIM0G,KSORT) !**** *DIST_SPEC_CONTROL* - Distribute global spectral array among processors ! Purpose. ! -------- ! Routine for distributing spectral array !** Interface. ! ---------- ! CALL DIST_SPEC_CONTROL(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! PSPEC(:,:) - Local spectral array ! KSORT(:) - Re-order fields on output ! Externals. SET2PE - compute "A and B" set from PE ! ---------- MPL.. - message passing routines ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! P.Marguinaud : 2014-10-10 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM,JPRB USE MPL_MODULE, ONLY: MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, JP_NON_BLOCKING_STANDARD USE TPM_DISTR, ONLY: MTAGDISTSP, MYSETV, NPRCIDS, NPRTRW, MYPROC, NPROC USE SET2PE_MOD, ONLY: SET2PE USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS ! IMPLICIT NONE REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2_G INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN), TARGET :: KSORT (:) INTEGER(KIND=JPIM) :: IDIST(KSPEC2_G) REAL(KIND=JPRB) :: ZFLD(KSPEC2) REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:,:) INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,JNM,IBSET,ILEN,JA,ISND INTEGER(KIND=JPIM) :: IRCV,ISTA,ISTP,ILENR,ISENDREQ(NPRTRW*KFDISTG) INTEGER(KIND=JPIM) :: ISENT INTEGER(KIND=JPIM), POINTER :: ISORT (:) ! ------------------------------------------------------------------ ! Compute help array for distribution IF (PRESENT (KSORT)) THEN ISORT => KSORT ELSE ALLOCATE (ISORT (KFDISTG)) DO JFLD = 1, KFDISTG ISORT (JFLD) = JFLD ENDDO ENDIF IF( NPROC == 1 ) THEN CALL GSTATS(1644,0) IF(LDIM1_IS_FLD) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JNM,JFLD) DO JNM=1,KSPEC2_G DO JFLD=1,KFDISTG PSPEC(ISORT (JFLD),JNM) = PSPECG(JFLD,JNM) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JNM,JFLD) DO JFLD=1,KFDISTG DO JNM=1,KSPEC2_G PSPEC(JNM,ISORT (JFLD)) = PSPECG(JNM,JFLD) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1644,1) ELSE II = 0 CALL GSTATS(1804,0) DO JM=0,KSMAX DO JN=JM,KSMAX IDIST(II+1) = KDIM0G(JM)+(JN-JM)*2 IDIST(II+2) = KDIM0G(JM)+(JN-JM)*2+1 II = II+2 ENDDO ENDDO CALL GSTATS(1804,1) !Distribute spectral array IFLDS = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN IFLDS = IFLDS+1 ENDIF ENDDO ALLOCATE(ZBUF(KSPEC2_G,IFLDS)) CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JNM,JFLD) DO JFLD=1,IFLDS IF(LDIM1_IS_FLD) THEN DO JNM=1,KSPEC2_G ZBUF(IDIST(JNM),JFLD) = PSPECG(JFLD,JNM) ENDDO ELSE DO JNM=1,KSPEC2_G ZBUF(IDIST(JNM),JFLD) = PSPECG(JNM,JFLD) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) IFLDR = 0 IFLDS = 0 ISENT = 0 CALL GSTATS_BARRIER(790) CALL GSTATS(812,0) DO JFLD=1,KFDISTG ! Send IF(KFROM(JFLD) == MYPROC) THEN IFLDS = IFLDS+1 IBSET = KVSET(JFLD) ITAG = MTAGDISTSP+JFLD DO JA=1,NPRTRW ILEN = KPOSSP(JA+1)-KPOSSP(JA) IF( ILEN > 0 )THEN CALL SET2PE(ISND,0,0,JA,IBSET) ISTA = KPOSSP(JA) ISTP = ISTA+ILEN-1 ISENT = ISENT+1 CALL MPL_SEND(ZBUF(ISTA:ISTP,IFLDS),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISENT),& &CDSTRING='DIST_SPEC_CONTROL:') ENDIF ENDDO ENDIF ENDDO !Receive DO JFLD=1,KFDISTG IBSET = KVSET(JFLD) IF( IBSET == MYSETV )THEN ITAG = MTAGDISTSP+JFLD IF( KSPEC2 > 0 )THEN IRCV = KFROM(JFLD) IFLDR = IFLDR+1 IF(LDIM1_IS_FLD) THEN CALL MPL_RECV(ZFLD,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KOUNT=ILENR,CDSTRING='DIST_SPEC_CONTROL:') PSPEC(ISORT (IFLDR),1:KSPEC2) = ZFLD(:) ELSE CALL MPL_RECV(PSPEC(:,ISORT (IFLDR)),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KOUNT=ILENR,CDSTRING='DIST_SPEC_CONTROL:') ENDIF IF( ILENR /= KSPEC2 )THEN CALL ABORT_TRANS('DIST_SPEC_CONTROL:INVALID RECEIVE MESSAGE LENGTH') ENDIF ENDIF ENDIF ENDDO DO JA=1,ISENT CALL MPL_WAIT(KREQUEST=ISENDREQ(JA), & & CDSTRING='DIST_SPEC_CTL: WAIT') ENDDO CALL GSTATS(812,1) CALL GSTATS_BARRIER2(790) !Synchronize processors CALL GSTATS(787,0) IF( NPROC > 1 )THEN CALL MPL_BARRIER(CDSTRING='DIST_SPEC_CONTROL:') ENDIF CALL GSTATS(787,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF IF (.NOT. PRESENT (KSORT)) THEN DEALLOCATE (ISORT) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIST_SPEC_CONTROL END MODULE DIST_SPEC_CONTROL_MOD ectrans-1.8.0/src/trans/gpu/internal/updspad_mod.F900000775000175000017500000001102115174631767022466 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE UPDSPAD_MOD CONTAINS SUBROUTINE UPDSPAD(KF_UV,KF_SCALARS,POA1, & & PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) !**** *UPDSPAD* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update the spectral arrays for a fixed zonal wave-number ! from values in POA1 and POA2. !** Interface. ! ---------- ! CALL UPDSPAD(...) ! Explicit arguments : ! -------------------- ! KM - zonal wave-number ! POA1 - spectral fields for zonal wavenumber KM (basic var.) ! PSPSCALAR - spectral scalar variables ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Externals. UPDSPBAD - basic transfer routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 94-08-02 R. El Khatib - interface to UPDSPB ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM ,JPRB, JPRBT USE TPM_TRANS, ONLY: NF_SC2, NF_SC3A, NF_SC3B USE TPM_DISTR, ONLY: D USE UPDSPBAD_MOD, ONLY: UPDSPBAD IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS REAL(KIND=JPRBT) , INTENT(OUT) :: POA1(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IST ,IEND,IDIM1,IDIM3,J3 ! ------------------------------------------------------------------ !* 1. UPDATE FIELDS ! ------------- !* 1.1 VORTICITY AND DIVERGENCE. #ifdef ACCGPU !$ACC DATA PRESENT(PSPSCALAR) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSCALAR)) !$ACC DATA PRESENT(PSPSC2) IF(NF_SC2 > 0) !$ACC DATA PRESENT(PSPSC3A) IF(NF_SC3A > 0) !$ACC DATA PRESENT(PSPSC3B) IF(NF_SC3B > 0) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSCALAR) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSCALAR)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSC2) IF(NF_SC2 > 0) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSC3A) IF(NF_SC3A > 0) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSC3B) IF(NF_SC3B > 0) #endif IST = 1 IST = IST+4*KF_UV !* 1.2 SCALARS IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IEND = IST+2*KF_SCALARS-1 CALL UPDSPBAD(KF_SCALARS,POA1(IST:IEND,:,:),PSPSCALAR,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IDIM1 = NF_SC2 IEND = IST+2*IDIM1-1 CALL UPDSPBAD(IDIM1,POA1(IST:IEND,:,:),PSPSC2) IST=IST+2*IDIM1 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPBAD(IDIM1,POA1(IST:IEND,:,:),PSPSC3A(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPBAD(IDIM1,POA1(IST:IEND,:,:),PSPSC3B(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF ENDIF ENDIF #ifdef OMPGPU !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif ! ------------------------------------------------------------------ END SUBROUTINE UPDSPAD END MODULE UPDSPAD_MOD ectrans-1.8.0/src/trans/gpu/internal/parkind_ectrans.F900000664000175000017500000000174015174631767023342 0ustar alastairalastair! (C) Copyright 2021- ECMWF. ! ! 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. ! MODULE PARKIND_ECTRANS ! ! Re-export precision-related symbols defined in fiat / parkind1, ! and add ECTRANS-internal precision-related symbols USE PARKIND1 ! Import everything from PARKIND1 ! IMPLICIT NONE SAVE ! ! Real Kind of compile-time precision for internal trans use ! ---------------------------------------------------------- ! #ifdef PARKINDTRANS_SINGLE INTEGER, PARAMETER :: JPRBT = SELECTED_REAL_KIND(6,37) #else INTEGER, PARAMETER :: JPRBT = SELECTED_REAL_KIND(13,300) #endif ! ! Half precision ! -------------- !!INTEGER, PARAMETER :: JPRL = 2 END MODULE PARKIND_ECTRANS ectrans-1.8.0/src/trans/gpu/internal/tpm_trans.F900000775000175000017500000000542615174631767022212 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TPM_TRANS ! Module to contain variables "local" to a specific call to a transform ! USE PARKIND_ECTRANS, ONLY: JPIM USE GROWING_ALLOCATOR_MOD, ONLY: GROWING_ALLOCATION_TYPE IMPLICIT NONE SAVE !INTEGER_M :: NF_UV ! Number of u-v fields (spectral/fourier space) !INTEGER_M :: NF_SCALARS ! Number of scalar fields (spectral/fourier space) !INTEGER_M :: NF_SCDERS ! Number of fields for derivatives of scalars ! (inverse transform, spectral/fourier space) !INTEGER_M :: NF_OUT_LT ! Number of fields that comes out of Inverse ! Legendre transform INTEGER(KIND=JPIM) :: NF_SC2 ! Number of fields in "SPSC2" arrays. INTEGER(KIND=JPIM) :: NF_SC3A ! Number of fields in "SPSC3A" arrays. INTEGER(KIND=JPIM) :: NF_SC3B ! Number of fields in "SPSC3B" arrays. !LOGICAL :: LUV ! uv fields requested !LOGICAL :: LSCALAR ! scalar fields requested LOGICAL :: LVORGP ! vorticity requested LOGICAL :: LDIVGP ! divergence requested LOGICAL :: LUVDER ! E-W derivatives of U and V requested LOGICAL :: LSCDERS ! derivatives of scalar variables are req. LOGICAL :: LATLON ! lat-lon output requested !INTEGER_M :: NLEI2 ! 8*NF_UV + 2*NF_SCALARS + 2*NF_SCDERS (dimension in ! inverse Legendre transform) !INTEGER_M :: NLED2 ! 2*NF_FS (dimension in direct Legendre transform) !INTEGER_M :: NF_FS ! Total number of fields in Fourier space !INTEGER_M :: NF_GP ! Total number of field in grid-point space !INTEGER_M :: NF_UV_G ! Global version of NF_UV (grid-point space) !INTEGER_M :: NF_SCALARS_G ! Global version of NF_SCALARS (grid-point space) INTEGER(KIND=JPIM) :: NPROMA ! Blocking factor for gridpoint input/output INTEGER(KIND=JPIM) :: NGPBLKS ! Number of NPROMA blocks LOGICAL :: LGPNORM = .FALSE. ! indicates whether transform is being done for gpnorm ! This is used in fourier space and in spectral space. It's reused among ! the transforms because we cannot reallocate - the captured graphs ! should not be modified. Hence, we keep it if it is large enough, otherwise ! we adapt the size. After 2 iterations this should lead to constant runtimes ! (the first iteration is used to get the max buffer size, the second iteration ! is going to recreate the graphs if needed) TYPE(GROWING_ALLOCATION_TYPE) :: GROWING_ALLOCATION END MODULE TPM_TRANS ectrans-1.8.0/src/trans/gpu/internal/trgtol_mod.F900000775000175000017500000007432615174631767022362 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRGTOL_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRGTOL_HANDLE, TRGTOL, PREPARE_TRGTOL TYPE TRGTOL_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HCOMBUFS, HCOMBUFR_AND_REEL END TYPE CONTAINS FUNCTION PREPARE_TRGTOL(ALLOCATOR,KF_GP,KF_FS) RESULT(HTRGTOL) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP, KF_FS TYPE(TRGTOL_HANDLE) :: HTRGTOL REAL(KIND=JPRBT) :: DUMMY INTEGER(KIND=JPIB) :: NELEM HTRGTOL%HCOMBUFS = RESERVE(ALLOCATOR, 1_JPIB*KF_GP*D%NGPTOT*C_SIZEOF(DUMMY), "HTRGTOL%HCOMBUFS") NELEM = 0 NELEM = NELEM + 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(DUMMY) ! ZCOMBUFR NELEM = NELEM + 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(DUMMY) ! PREEL_REAL HTRGTOL%HCOMBUFR_AND_REEL = RESERVE(ALLOCATOR, NELEM, "HTRGTOL%HCOMBUFR_AND_REEL") END FUNCTION PREPARE_TRGTOL SUBROUTINE TRGTOL(ALLOCATOR,HTRGTOL,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,& &PGP,PGPUV,PGP3A,PGP3B,PGP2,KPTRGP,KVSETUV,KVSETSC,KVSETSC3A,KVSETSC3B,KVSETSC2) !**** *TRGTOL * - transposition of grid point data from column ! structure to latitudinal. Reorganize data between ! grid point calculations and direct Fourier Transform ! Version using CUDA-aware MPI ! Purpose. ! -------- !** Interface. ! ---------- ! *call* *trgtol(...) ! Explicit arguments : ! -------------------- ! PREEL_REAL - Latitudinal data ready for direct FFT (output) ! PGP - Blocked grid point data (input) ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original: 95-10-01 ! D.Dent : 97-08-04 Reorganisation to allow ! NPRTRV to differ from NPRGPEW ! : 98-06-17 add mailbox control logic (from TRLTOM) ! =99-03-29= Mats Hamrud and Deborah Salmond ! JUMP in FFT's changed to 1 ! KINDEX introduced and ZCOMBUF not used for same PE ! 01-11-23 Deborah Salmond and John Hague ! LIMP_NOOLAP Option for non-overlapping message passing ! and buffer packing ! 01-12-18 Peter Towers ! Improved vector performance of GTOL_PACK,GTOL_UNPACK ! 03-04-02 G. Radnoti: call barrier always when nproc>1 ! 08-01-01 G.Mozdzynski: cleanup ! 09-01-02 G.Mozdzynski: use non-blocking recv and send ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_WAIT, MPL_BARRIER, MPL_ABORT, MPL_RECV, MPL_SEND USE TPM_GEN, ONLY: LSYNC_TRANS, LMPOFF USE EQ_REGIONS_MOD, ONLY: MY_REGION_EW, MY_REGION_NS USE TPM_DISTR, ONLY: D, MYSETV, MYSETW, MTAGLG, NPRCIDS, MYPROC, NPROC, NPRTRW, & & NPRTRV USE PE2SET_MOD, ONLY: PE2SET USE MPL_DATA_MODULE, ONLY: MPL_COMM_OML, JP_NON_BLOCKING_STANDARD USE OML_MOD, ONLY: OML_MY_THREAD #ifdef USE_RAW_MPI USE MPI_F08, ONLY: MPI_COMM, MPI_REQUEST, MPI_REAL4, MPI_REAL8 ! Missing: MPI_ISEND, MPI_IRECV on purpose due to cray-mpi bug (see https://github.com/ecmwf-ifs/ectrans/pull/157) #endif USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE TPM_TRANS, ONLY: NPROMA USE ISO_C_BINDING, ONLY: C_SIZEOF USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE OPENACC_EXT, ONLY: EXT_ACC_ARR_DESC, EXT_ACC_PASS, EXT_ACC_CREATE, & & EXT_ACC_DELETE #ifdef ACCGPU USE OPENACC, ONLY: ACC_HANDLE_KIND #endif USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE REAL(KIND=JPRBT),INTENT(OUT), POINTER :: PREEL_REAL(:) INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:), KVSETSC(:), KVSETSC3A(:), KVSETSC3B(:), KVSETSC2(:) REAL(KIND=JPRB),OPTIONAL,INTENT(IN) :: PGP(:,:,:), PGPUV(:,:,:,:), PGP3A(:,:,:,:), PGP3B(:,:,:,:), PGP2(:,:,:) TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRGTOL_HANDLE), INTENT(IN) :: HTRGTOL ! LOCAL VARIABLES ! LOCAL INTEGER SCALARS REAL(KIND=JPRBT), POINTER :: ZCOMBUFS(:),ZCOMBUFR(:) LOGICAL :: LLOCAL_CONTRIBUTION INTEGER(KIND=JPIB) :: ISENDTOT (NPROC) INTEGER(KIND=JPIB) :: IRECVTOT (NPROC) INTEGER(KIND=JPIM) :: ISENDTOT_MPI(NPROC) INTEGER(KIND=JPIM) :: IRECVTOT_MPI(NPROC) INTEGER(KIND=JPIM) :: IREQ (NPROC*2) INTEGER(KIND=JPIM) :: IRECV_TO_PROC(NPROC) INTEGER(KIND=JPIM) :: ISEND_TO_PROC(NPROC) INTEGER(KIND=JPIM) :: IFIRSTLAT, IGL, IGLL,& &ILASTLAT, ILEN, JROC, ISETA, & &ISETB, IRECV, & &ISETV, ISEND, JBLK, JFLD, & &JGL, JI, JK, JL, ISETW, IFLD, & &IRECV_COUNTS, IPROC,IFLDS, & &ISEND_COUNTS,INS,INR,IR, PBOUND, IERROR, ILOCAL_LAT INTEGER(KIND=JPIM) :: KF, KI, J3 INTEGER(KIND=JPIB) :: IPOS INTEGER(KIND=JPIM) :: IOFF, ILAT_STRIP INTEGER(KIND=JPIB) :: IRECV_BUFR_TO_OUT(D%NLENGTF,2) INTEGER(KIND=JPIB) :: IRECV_BUFR_TO_OUT_OFFSET(NPROC), IRECV_BUFR_TO_OUT_V INTEGER(KIND=JPIM) :: ISEND_FIELD_COUNT(NPRTRV),ISEND_FIELD_COUNT_V INTEGER(KIND=JPIM) :: ISEND_WSET_SIZE(NPRTRW),ISEND_WSET_SIZE_V INTEGER(KIND=JPIM) :: ISEND_WSET_OFFSET(NPRTRW+1), ISEND_WSET_OFFSET_V INTEGER(KIND=JPIB), ALLOCATABLE :: ICOMBUFS_OFFSET(:),ICOMBUFR_OFFSET(:), IFLDA(:,:) INTEGER(KIND=JPIB) :: ICOMBUFS_OFFSET_V, ICOMBUFR_OFFSET_V INTEGER(KIND=JPIM) :: IVSET(KF_GP) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(JPIM), PARAMETER :: PGP_INDICES_UV = 1 INTEGER(JPIM), PARAMETER :: PGP_INDICES_GP2 = 2 INTEGER(JPIM), PARAMETER :: PGP_INDICES_GP3A = 3 INTEGER(JPIM), PARAMETER :: PGP_INDICES_GP3B = 4 INTEGER(JPIM), PARAMETER :: PGP_INDICES_END = 5 INTEGER(JPIM) :: PGP_INDICES(PGP_INDICES_END) TYPE(EXT_ACC_ARR_DESC) :: ACC_POINTERS(5) ! at most 5 copyins... INTEGER(KIND=JPIM) :: ACC_POINTERS_CNT #ifdef USE_RAW_MPI TYPE(MPI_COMM) :: LOCAL_COMM TYPE(MPI_REQUEST) :: IREQUEST(2*NPROC) #else INTEGER(JPIM) :: IREQUEST(2*NPROC) #endif #ifdef PARKINDTRANS_SINGLE #define TRGTOL_DTYPE MPI_REAL4 #else #define TRGTOL_DTYPE MPI_REAL8 #endif #ifdef USE_RAW_MPI IF(.NOT. LMPOFF) THEN LOCAL_COMM%MPI_VAL = MPL_COMM_OML( OML_MY_THREAD() ) ENDIF #endif ! ------------------------------------------------------------------ !* 0. Some initializations ! -------------------- ! Note we have either ! - KVSETUV and KVSETSC (with PGP, which has u, v, and scalar fields), or ! - KVSETUV, KVSETSC2, KVSETSC3A KVSETSC3B (with PGPUV, GP3A, PGP3B and PGP2) ! KVSETs are optionals. Their sizes can also be inferred from KV_UV_G/KV_SCALARS_G (which ! should match PSPXXX and PGPXXX arrays) IOFF=0 IVSET(:) = -1 IF(PRESENT(KVSETUV)) THEN IVSET(IOFF+1:IOFF+KF_UV_G) = KVSETUV(:) IOFF=IOFF+KF_UV_G IVSET(IOFF+1:IOFF+KF_UV_G) = KVSETUV(:) IOFF=IOFF+KF_UV_G ELSE IVSET(IOFF+1:IOFF+KF_UV_G) = -1 IOFF=IOFF+KF_UV_G IVSET(IOFF+1:IOFF+KF_UV_G) = -1 IOFF=IOFF+KF_UV_G ENDIF IF(PRESENT(KVSETSC)) THEN IVSET(IOFF+1:IOFF+KF_SCALARS_G) = KVSETSC(:) IOFF=IOFF+KF_SCALARS_G ELSE IF(PRESENT(KVSETSC2)) THEN IVSET(IOFF+1:IOFF+SIZE(KVSETSC2)) = KVSETSC2(:) IOFF=IOFF+SIZE(KVSETSC2) ENDIF IF(PRESENT(KVSETSC3A)) THEN DO J3=1,SIZE(PGP3A,3) IVSET(IOFF+1:IOFF+SIZE(KVSETSC3A))=KVSETSC3A(:) IOFF=IOFF+SIZE(KVSETSC3A) ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN DO J3=1,SIZE(PGP3B,3) IVSET(IOFF+1:IOFF+SIZE(KVSETSC3B))=KVSETSC3B(:) IOFF=IOFF+SIZE(KVSETSC3B) ENDDO ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('TRGTOL',0,ZHOOK_HANDLE) CALL GSTATS(1805,0) IOFF=1 PGP_INDICES(PGP_INDICES_UV) = IOFF IF (PRESENT(PGPUV)) IOFF=IOFF+UBOUND(PGPUV,2)*2 PGP_INDICES(PGP_INDICES_GP2) = IOFF IF (PRESENT(PGP2)) IOFF=IOFF+UBOUND(PGP2,2) PGP_INDICES(PGP_INDICES_GP3A) = IOFF IF (PRESENT(PGP3A)) IOFF=IOFF+UBOUND(PGP3A,2)*UBOUND(PGP3A,3) PGP_INDICES(PGP_INDICES_GP3B) = IOFF IF (PRESENT(PGP3B)) IOFF=IOFF+UBOUND(PGP3B,2)*UBOUND(PGP3B,3) PGP_INDICES(PGP_INDICES_END) = IOFF ! Prepare sender arrays ! find number of fields on a certain V-set IF(NPRTRV == 1) THEN ! This is needed because IVSET(JFLD) == -1 if there is only one V-set ISEND_FIELD_COUNT(1) = KF_GP ELSE ISEND_FIELD_COUNT(:) = 0 DO JFLD=1,KF_GP ISEND_FIELD_COUNT(IVSET(JFLD)) = ISEND_FIELD_COUNT(IVSET(JFLD)) + 1 ENDDO ENDIF ! find number of grid-points on a certain W-set that overlap with myself ISEND_WSET_SIZE(:) = 0 DO ILOCAL_LAT=D%NFRSTLAT(MY_REGION_NS),D%NLSTLAT(MY_REGION_NS) ILAT_STRIP = ILOCAL_LAT-D%NFRSTLAT(MY_REGION_NS)+D%NPTRFLOFF+1 ISEND_WSET_SIZE(D%NPROCL(ILOCAL_LAT)) = & & ISEND_WSET_SIZE(D%NPROCL(ILOCAL_LAT))+D%NONL(ILAT_STRIP,MY_REGION_EW) ENDDO ! sum up offsets ISEND_WSET_OFFSET(1) = 0 DO JROC=1,NPRTRW ISEND_WSET_OFFSET(JROC+1)=ISEND_WSET_OFFSET(JROC)+ISEND_WSET_SIZE(JROC) ENDDO DO JROC=1,NPROC CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) ! total send size is # points per field * # fields ISENDTOT(JROC) = 1_JPIB*ISEND_WSET_SIZE(ISETW)*ISEND_FIELD_COUNT(ISETV) ENDDO LLOCAL_CONTRIBUTION = ISENDTOT(MYPROC) > 0 ! Prepare receiver arrays IRECV_BUFR_TO_OUT_OFFSET(:) = 0 DO JROC=1,NPROC ! Get new offset to my current KINDEX entry IF (JROC > 1 .AND. KF_FS > 0) THEN IRECV_BUFR_TO_OUT_OFFSET(JROC) = IRECV_BUFR_TO_OUT_OFFSET(JROC-1)+IRECVTOT(JROC-1)/KF_FS ELSEIF (JROC > 1) THEN IRECV_BUFR_TO_OUT_OFFSET(JROC) = IRECV_BUFR_TO_OUT_OFFSET(JROC-1) ENDIF CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) ! MAX(Index of first fourier latitude for this W set, first latitude of a senders A set) ! i.e. we find the overlap between what we have on sender side (others A set) and the receiver ! (me, the W-set). Ideally those conincide, at least mostly. IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA)) ! MIN(Index of last fourier latitude for this W set, last latitude of a senders A set) ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA)) IPOS = 0 DO JGL=IFIRSTLAT,ILASTLAT ! get from "actual" latitude to the latitude strip offset IGL = JGL-D%NFRSTLAT(ISETA)+D%NPTRFRSTLAT(ISETA) ! get from "actual" latitude to the latitude offset IGLL = JGL-D%NPTRLS(MYSETW)+1 DO JL=1,D%NONL(IGL,ISETB) IPOS = IPOS+1 ! offset to first layer of this gridpoint IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_OFFSET(JROC)+IPOS,1) = & & KF_FS*D%NSTAGTF(IGLL)+(D%NSTA(IGL,ISETB)-1)+(JL-1) ! distance between two layers of this gridpoint IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_OFFSET(JROC)+IPOS,2) = & & D%NSTAGTF(IGLL+1)-D%NSTAGTF(IGLL) ENDDO ENDDO !we always receive the full fourier space IRECVTOT(JROC) = IPOS*KF_FS ENDDO block CALL ASSIGN_PTR(PREEL_REAL, GET_ALLOCATION(ALLOCATOR, HTRGTOL%HCOMBUFR_AND_REEL),& & 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(PREEL_REAL(1))+1, 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(PREEL_REAL(1))) !!CALL ASSIGN_PTR(PREEL_REAL, GET_ALLOCATION(ALLOCATOR, HTRGTOL%HCOMBUFR_AND_REEL), size1, size2) end block #ifdef OMPGPU !$OMP TARGET DATA MAP(TO:IRECV_BUFR_TO_OUT) MAP(PRESENT,ALLOC:PREEL_REAL) IF (KF_FS > 0) !$OMP TARGET DATA MAP(TO:PGP_INDICES) #endif #ifdef ACCGPU !$ACC DATA COPYIN(IRECV_BUFR_TO_OUT) PRESENT(PREEL_REAL) IF (KF_FS > 0) ASYNC(1) !$ACC DATA COPYIN(PGP_INDICES) ASYNC(1) #endif CALL GSTATS(1805,1) ! Put data on device for copyin IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(430,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(412,0) ACC_POINTERS_CNT = 0 IF (PRESENT(PGP)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP) ENDIF IF (PRESENT(PGPUV)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGPUV) ENDIF IF (PRESENT(PGP2)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP2) ENDIF IF (PRESENT(PGP3A)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3A) ENDIF IF (PRESENT(PGP3B)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3B) ENDIF IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_CREATE(ACC_POINTERS(1:ACC_POINTERS_CNT), & #ifdef ACCGPU & STREAM=1_ACC_HANDLE_KIND) #endif #ifdef OMPGPU & STREAM=1) #endif #ifdef ACCGPU !$ACC WAIT(1) #endif IF (PRESENT(PGP)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE TO(PGP) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PGP) #endif ENDIF IF (PRESENT(PGPUV)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE TO(PGPUV) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PGPUV) #endif ENDIF IF (PRESENT(PGP2)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE TO(PGP2) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PGP2) #endif ENDIF IF (PRESENT(PGP3A)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE TO(PGP3A) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PGP3A) #endif ENDIF IF (PRESENT(PGP3B)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE TO(PGP3B) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PGP3B) #endif ENDIF #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP) IF(PRESENT(PGP) .AND. KF_GP > 0) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGPUV) IF(PRESENT(PGPUV)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP2) IF(PRESENT(PGP2)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP3A) IF(PRESENT(PGP3A)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP3B) IF(PRESENT(PGP3B)) #endif #ifdef ACCGPU !$ACC DATA IF(PRESENT(PGP) .AND. KF_GP > 0) PRESENT(PGP) ASYNC(1) !$ACC DATA IF(PRESENT(PGPUV)) PRESENT(PGPUV) ASYNC(1) !$ACC DATA IF(PRESENT(PGP2)) PRESENT(PGP2) ASYNC(1) !$ACC DATA IF(PRESENT(PGP3A)) PRESENT(PGP3A) ASYNC(1) !$ACC DATA IF(PRESENT(PGP3B)) PRESENT(PGP3B) ASYNC(1) #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(432,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(432,1) ENDIF CALL GSTATS(412,1) ! Figure out processes that send or recv something ISEND_COUNTS = 0 IRECV_COUNTS = 0 DO JROC=1,NPROC IF( JROC /= MYPROC) THEN IF(IRECVTOT(JROC) > 0) THEN ! I have to recv something, so let me store that IRECV_COUNTS = IRECV_COUNTS + 1 IRECV_TO_PROC(IRECV_COUNTS)=JROC ENDIF IF(ISENDTOT(JROC) > 0) THEN ! I have to send something, so let me store that ISEND_COUNTS = ISEND_COUNTS+1 ISEND_TO_PROC(ISEND_COUNTS)=JROC ENDIF ENDIF ENDDO ALLOCATE(ICOMBUFS_OFFSET(ISEND_COUNTS+1)) ICOMBUFS_OFFSET(1) = 0 DO JROC=1,ISEND_COUNTS ICOMBUFS_OFFSET(JROC+1) = ICOMBUFS_OFFSET(JROC) + ISENDTOT(ISEND_TO_PROC(JROC)) ENDDO ALLOCATE(ICOMBUFR_OFFSET(IRECV_COUNTS+1)) ICOMBUFR_OFFSET(1) = 0 DO JROC=1,IRECV_COUNTS ICOMBUFR_OFFSET(JROC+1) = ICOMBUFR_OFFSET(JROC) + IRECVTOT(IRECV_TO_PROC(JROC)) ENDDO IF (ISEND_COUNTS > 0) THEN CALL ASSIGN_PTR(ZCOMBUFS, GET_ALLOCATION(ALLOCATOR, HTRGTOL%HCOMBUFS),& & 1_JPIB, ICOMBUFS_OFFSET(ISEND_COUNTS+1)*C_SIZEOF(ZCOMBUFS(1))) ENDIF !....Pack loop......................................................... #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:ZCOMBUFS) IF(ISEND_COUNTS > 0) #endif #ifdef ACCGPU !$ACC DATA IF(ISEND_COUNTS > 0) PRESENT(ZCOMBUFS) ASYNC(1) #endif CALL GSTATS(1602,0) ! Allocate this buffer. Add 1 for the potential self sends ALLOCATE(IFLDA(KF_GP,1+ISEND_COUNTS)) IF(LLOCAL_CONTRIBUTION)THEN ! I have to send something to myself... ! Input is KF_GP fields. We find the resulting KF_FS fields. IFLDS = 0 DO JFLD=1,KF_GP IF(IVSET(JFLD) == MYSETV .OR. IVSET(JFLD) == -1) THEN IFLDS = IFLDS+1 IF(PRESENT(KPTRGP)) THEN IFLDA(IFLDS,1) = KPTRGP(JFLD) ELSE IFLDA(IFLDS,1) = JFLD ENDIF ENDIF ENDDO ENDIF DO INS=1,ISEND_COUNTS ISEND=ISEND_TO_PROC(INS) CALL PE2SET(ISEND,ISETA,ISETB,ISETW,ISETV) IFLDS = 0 DO JFLD=1,KF_GP IF(IVSET(JFLD) == ISETV .OR. IVSET(JFLD) == -1 ) THEN IFLDS = IFLDS+1 IF(PRESENT(KPTRGP)) THEN IFLDA(IFLDS,1+INS)=KPTRGP(JFLD) ELSE IFLDA(IFLDS,1+INS)=JFLD ENDIF ENDIF ENDDO ENDDO #ifdef OMPGPU !$OMP TARGET DATA MAP(TO:IFLDA) #endif #ifdef ACCGPU !$ACC DATA COPYIN(IFLDA) ASYNC(1) #endif DO INS=1,ISEND_COUNTS ISEND=ISEND_TO_PROC(INS) CALL PE2SET(ISEND,ISETA,ISETB,ISETW,ISETV) ISEND_FIELD_COUNT_V = ISEND_FIELD_COUNT(ISETV) ICOMBUFS_OFFSET_V = ICOMBUFS_OFFSET(INS) ISEND_WSET_OFFSET_V = ISEND_WSET_OFFSET(ISETW) ISEND_WSET_SIZE_V = ISEND_WSET_SIZE(ISETW) IF(PRESENT(PGP)) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) & !$OMP& PRIVATE(JK,JBLK,IFLD,JI) SHARED(ISEND_FIELD_COUNT_V,ISEND_WSET_SIZE_V,NPROMA,& !$OMP& ISEND_WSET_OFFSET_V,INS,ICOMBUFS_OFFSET_V,IFLDA,PGP,ZCOMBUFS) & !$OMP& MAP(TO:ISEND_FIELD_COUNT_V,ISEND_WSET_SIZE_V,NPROMA,ISEND_WSET_OFFSET_V,& !$OMP& INS,ICOMBUFS_OFFSET_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI) & !$ACC& FIRSTPRIVATE(INS,ISEND_FIELD_COUNT_V,ISEND_WSET_SIZE_V,ISEND_WSET_OFFSET_V,& !$ACC& ICOMBUFS_OFFSET_V,NPROMA) ASYNC(1) #endif DO JFLD=1,ISEND_FIELD_COUNT_V DO JL=1,ISEND_WSET_SIZE_V JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD = IFLDA(JFLD,1+INS) JI = (JFLD-1)*ISEND_WSET_SIZE_V+JL ZCOMBUFS(ICOMBUFS_OFFSET_V+JI) = PGP(JK,IFLD,JBLK) ENDDO ENDDO ELSE #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,& !$OMP& JI,IOFF,PBOUND) SHARED(ISEND_FIELD_COUNT_V,ISEND_WSET_SIZE_V,NPROMA,& !$OMP& ISEND_WSET_OFFSET_V,INS,IFLDA,ICOMBUFS_OFFSET_V,PGP_INDICES,PGPUV,ZCOMBUFS,PGP2,& !$OMP& PGP3A,PGP3B) MAP(TO:ISEND_FIELD_COUNT_V,ISEND_WSET_SIZE_V,NPROMA,& !$OMP& ISEND_WSET_OFFSET_V,ICOMBUFS_OFFSET_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI,IOFF,PBOUND) & !$ACC& FIRSTPRIVATE(INS,ISEND_FIELD_COUNT_V,ISEND_WSET_SIZE_V,ISEND_WSET_OFFSET_V,& !$ACC& ICOMBUFS_OFFSET_V,NPROMA) ASYNC(1) #endif DO JFLD=1,ISEND_FIELD_COUNT_V DO JL=1,ISEND_WSET_SIZE_V JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD = IFLDA(JFLD,1+INS) JI = ICOMBUFS_OFFSET_V+(JFLD-1)*ISEND_WSET_SIZE_V+JL IF(IFLD < PGP_INDICES(PGP_INDICES_UV+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_UV) PBOUND=UBOUND(PGPUV,2) ! TODO we could certainly reshape PGPXX arrays and we would simplify this ZCOMBUFS(JI) = PGPUV(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP2+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP2) ZCOMBUFS(JI) = PGP2(JK,IOFF+1,JBLK) ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3A+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3A) PBOUND=UBOUND(PGP3A,2) ZCOMBUFS(JI) = PGP3A(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3B+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3B) PBOUND=UBOUND(PGP3B,2) ZCOMBUFS(JI)= PGP3B(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ENDIF ENDDO ENDDO ENDIF ENDDO #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(1602,1) IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(411,0) IF (IRECV_COUNTS > 0) THEN CALL ASSIGN_PTR(ZCOMBUFR, GET_ALLOCATION(ALLOCATOR, HTRGTOL%HCOMBUFR_AND_REEL),& & 1_JPIB, ICOMBUFR_OFFSET(IRECV_COUNTS+1)*C_SIZEOF(ZCOMBUFR(1))) ENDIF #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:ZCOMBUFR) IF(IRECV_COUNTS > 0) #endif #ifdef ACCGPU !$ACC DATA IF(IRECV_COUNTS > 0) PRESENT(ZCOMBUFR) ASYNC(1) #endif IR=0 #ifdef USE_GPU_AWARE_MPI #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_PTR(ZCOMBUFR,ZCOMBUFS) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZCOMBUFR,ZCOMBUFS) #endif #else #ifdef OMPGPU !$OMP TARGET UPDATE FROM(ZCOMBUFS) IF(ISEND_COUNTS > 0) #endif #ifdef ACCGPU !! this is safe-but-slow fallback for running without GPU-aware MPI !$ACC UPDATE HOST(ZCOMBUFS) IF(ISEND_COUNTS > 0) #endif #endif ! Skip the own contribution because this is ok to overflow ISENDTOT(MYPROC) = 0 IRECVTOT(MYPROC) = 0 ISENDTOT_MPI = ISENDTOT IRECVTOT_MPI = IRECVTOT IF (ANY(ISENDTOT_MPI /= ISENDTOT)) & & CALL MPL_ABORT("Overflow in trgtol") IF (ANY(IRECVTOT_MPI /= IRECVTOT)) & & CALL MPL_ABORT("Overflow in trgtol") ! Receive loop......................................................... DO INR=1,IRECV_COUNTS IR=IR+1 IPROC=IRECV_TO_PROC(INR) #ifdef USE_RAW_MPI CALL MPI_IRECV(ZCOMBUFR(ICOMBUFR_OFFSET(INR)+1:ICOMBUFR_OFFSET(INR+1)),IRECVTOT_MPI(IPROC), & & TRGTOL_DTYPE,NPRCIDS(IPROC)-1,MTAGLG,LOCAL_COMM,IREQUEST(IR),IERROR) IREQ(IR) = IREQUEST(IR)%MPI_VAL #else CALL MPL_RECV(ZCOMBUFR(ICOMBUFR_OFFSET(INR)+1:ICOMBUFR_OFFSET(INR+1)), & & KSOURCE=NPRCIDS(IPROC), KTAG=MTAGLG, KMP_TYPE=JP_NON_BLOCKING_STANDARD, & & KREQUEST=IREQUEST(IR)) IREQ(IR) = IREQUEST(IR) #endif ENDDO !....Send loop......................................................... DO INS=1,ISEND_COUNTS IR=IR+1 ISEND=ISEND_TO_PROC(INS) #ifdef USE_RAW_MPI CALL MPI_ISEND(ZCOMBUFS(ICOMBUFS_OFFSET(INS)+1:ICOMBUFS_OFFSET(INS+1)),ISENDTOT_MPI(ISEND), & & TRGTOL_DTYPE,NPRCIDS(ISEND)-1,MTAGLG,LOCAL_COMM,IREQUEST(IR),IERROR) IREQ(IR) = IREQUEST(IR)%MPI_VAL #else CALL MPL_SEND(ZCOMBUFS(ICOMBUFS_OFFSET(INS)+1:ICOMBUFS_OFFSET(INS+1)), & & KDEST=NPRCIDS(ISEND), KTAG=MTAGLG, KMP_TYPE=JP_NON_BLOCKING_STANDARD, & & KREQUEST=IREQUEST(IR)) IREQ(IR) = IREQUEST(IR) #endif ENDDO ! Copy local contribution IF(LLOCAL_CONTRIBUTION)THEN ISEND_WSET_OFFSET_V = ISEND_WSET_OFFSET(MYSETW) ISEND_WSET_SIZE_V = ISEND_WSET_SIZE(MYSETW) IRECV_BUFR_TO_OUT_V = IRECV_BUFR_TO_OUT_OFFSET(MYPROC) CALL GSTATS(1601,0) IF(PRESENT(PGP)) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,& !$OMP& IPOS) SHARED(KF_FS,ISEND_WSET_SIZE_V,NPROMA,ISEND_WSET_OFFSET_V,IFLDA,& !$OMP& IRECV_BUFR_TO_OUT_V,IRECV_BUFR_TO_OUT,PGP,PREEL_REAL) MAP(TO:KF_FS,IRECV_BUFR_TO_OUT_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS) & !$ACC& FIRSTPRIVATE(KF_FS,ISEND_WSET_SIZE_V,ISEND_WSET_OFFSET_V,& !$ACC& IRECV_BUFR_TO_OUT_V,NPROMA) ASYNC(1) #endif DO JFLD=1,KF_FS DO JL=1,ISEND_WSET_SIZE_V JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD = IFLDA(JFLD,1) IPOS = IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,1)+ & & (JFLD-1)*IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,2)+1 PREEL_REAL(IPOS) = PGP(JK,IFLD,JBLK) ENDDO ENDDO ELSE #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,& !$OMP& IPOS,IOFF,PBOUND) SHARED(KF_FS,ISEND_WSET_SIZE_V,NPROMA,ISEND_WSET_OFFSET_V,IFLDA,& !$OMP& IRECV_BUFR_TO_OUT_V,IRECV_BUFR_TO_OUT,PGP_INDICES,PGPUV,PREEL_REAL,PGP2,PGP3A,PGP3B) & !$OMP& MAP(TO:KF_FS) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS,IOFF,PBOUND) & !$ACC& FIRSTPRIVATE(KF_FS,ISEND_WSET_SIZE_V,ISEND_WSET_OFFSET_V, & !$ACC& IRECV_BUFR_TO_OUT_V,NPROMA) ASYNC(1) #endif DO JFLD=1,KF_FS DO JL=1,ISEND_WSET_SIZE_V JK = MOD(ISEND_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (ISEND_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD = IFLDA(JFLD,1) IPOS = IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,1)+ & & (JFLD-1)*IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,2)+1 IF(IFLD < PGP_INDICES(PGP_INDICES_UV+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_UV) PBOUND=UBOUND(PGPUV,2) PREEL_REAL(IPOS) = PGPUV(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP2+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP2) PREEL_REAL(IPOS) = PGP2(JK,IOFF+1,JBLK) ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3A+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3A) PBOUND=UBOUND(PGP3A,2) PREEL_REAL(IPOS) = PGP3A(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ELSEIF(IFLD < PGP_INDICES(PGP_INDICES_GP3B+1)) THEN IOFF=IFLD-PGP_INDICES(PGP_INDICES_GP3B) PBOUND=UBOUND(PGP3B,2) PREEL_REAL(IPOS) = PGP3B(JK,MOD(IOFF,PBOUND)+1,IOFF/PBOUND+1,JBLK) ENDIF ENDDO ENDDO ENDIF CALL GSTATS(1601,1) ENDIF IF(IR > 0) THEN CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & & CDSTRING='TRGTOL: WAIT FOR SENDS AND RECEIVES') ENDIF #ifdef USE_GPU_AWARE_MPI #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #else #ifdef OMPGPU !$OMP TARGET UPDATE TO(ZCOMBUFR) IF(IRECV_COUNTS > 0) #endif #ifdef ACCGPU !! this is safe-but-slow fallback for running without GPU-aware MPI !$ACC UPDATE DEVICE(ZCOMBUFR) IF(IRECV_COUNTS > 0) #endif #endif IF (LSYNC_TRANS) THEN CALL GSTATS(431,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(431,1) ENDIF CALL GSTATS(411,1) ! Unpack loop......................................................... CALL GSTATS(1603,0) DO INR=1,IRECV_COUNTS IPROC=IRECV_TO_PROC(INR) ILEN = IRECVTOT(IPROC)/KF_FS IRECV_BUFR_TO_OUT_V = IRECV_BUFR_TO_OUT_OFFSET(IPROC) ICOMBUFR_OFFSET_V = ICOMBUFR_OFFSET(INR) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) PRIVATE(IPOS) & !$OMP& SHARED(KF_FS,ILEN,IRECV_BUFR_TO_OUT_V,IRECV_BUFR_TO_OUT,ICOMBUFR_OFFSET_V,ZCOMBUFR,& !$OMP& PREEL_REAL) MAP(TO:IRECV_BUFR_TO_OUT_V,ICOMBUFR_OFFSET_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(IPOS) FIRSTPRIVATE(KF_FS,ILEN, & !$ACC& IRECV_BUFR_TO_OUT_V,ICOMBUFR_OFFSET_V) ASYNC(1) #endif DO JFLD=1,KF_FS DO JL=1,ILEN IPOS = IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,1)+ & & (JFLD-1)*IRECV_BUFR_TO_OUT(IRECV_BUFR_TO_OUT_V+JL,2)+1 PREEL_REAL(IPOS) = ZCOMBUFR(ICOMBUFR_OFFSET_V+JL+(JFLD-1)*ILEN) ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(1603,1) #ifdef OMPGPU !$OMP END TARGET DATA ! ZCOMBUFR !$OMP END TARGET DATA ! IFLDA !$OMP END TARGET DATA ! IRECV_BUFR_TO_OUT !$OMP END TARGET DATA ! PGPINDICES !$OMP END TARGET DATA !ZCOMBUFS (present) !$OMP END TARGET DATA !PGP3B !$OMP END TARGET DATA !PGP3A !$OMP END TARGET DATA !PGP2 !$OMP END TARGET DATA !PGPUV !$OMP END TARGET DATA !PGP #endif #ifdef ACCGPU !$ACC END DATA ! ZCOMBUFR !$ACC END DATA ! IFLDA !$ACC END DATA ! IRECV_BUFR_TO_OUT !$ACC END DATA ! PGPINDICES !$ACC END DATA !ZCOMBUFS (present) !$ACC END DATA !PGP3B !$ACC END DATA !PGP3A !$ACC END DATA !PGP2 !$ACC END DATA !PGPUV !$ACC END DATA !PGP #endif IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_DELETE(ACC_POINTERS(1:ACC_POINTERS_CNT), & #ifdef ACCGPU & STREAM=1_ACC_HANDLE_KIND) #endif #ifdef OMPGPU & STREAM=1) #endif ! Free this now DEALLOCATE(IFLDA) IF (LHOOK) CALL DR_HOOK('TRGTOL',1,ZHOOK_HANDLE) END SUBROUTINE TRGTOL END MODULE TRGTOL_MOD ectrans-1.8.0/src/trans/gpu/internal/spnormc_mod.F900000775000175000017500000000501215174631767022512 0ustar alastairalastair! (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. ! MODULE SPNORMC_MOD CONTAINS SUBROUTINE SPNORMC(PSM,KFLD_G,KVSET,KMASTER,KSMAX,PGM) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT USE MPL_MODULE, ONLY: MPL_RECV, MPL_SEND, MPL_BARRIER USE TPM_DISTR, ONLY: D, NPRCIDS, NPRTRV, MYPROC, NPROC USE PE2SET_MOD, ONLY: PE2SET IMPLICIT NONE REAL(KIND=JPRBT) ,INTENT(IN) :: PSM(:,:) INTEGER(KIND=JPIM) ,INTENT(IN) :: KFLD_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,INTENT(IN) :: KMASTER INTEGER(KIND=JPIM) ,INTENT(IN) :: KSMAX REAL(KIND=JPRBT) ,INTENT(OUT) :: PGM(KFLD_G,0:KSMAX) REAL(KIND=JPRBT) :: ZRECVBUF(SIZE(PGM)) INTEGER(KIND=JPIM) :: IFLDR(NPRTRV) INTEGER(KIND=JPIM) :: ISTOTAL,JFLD,ITAG,JROC,IMSGLEN,IRECVID INTEGER(KIND=JPIM) :: IRECVNUMP,IRECVFLD,IFLD,JMLOC,IM,IBUFLENR,IA,IB INTEGER(KIND=JPIM) :: IRECVSETA,IRECVSETB ! ------------------------------------------------------------------ ISTOTAL = SIZE(PSM) IBUFLENR = SIZE(ZRECVBUF) IFLDR(:) = 0 DO JFLD=1,KFLD_G IFLDR(KVSET(JFLD)) = IFLDR(KVSET(JFLD))+1 ENDDO ITAG = 100 IF (NPROC > 1.AND.MYPROC /= KMASTER) THEN CALL MPL_SEND(PSM(:,:),KDEST=NPRCIDS(KMASTER),KTAG=ITAG,& &CDSTRING='SPNORMC:') ENDIF IF (MYPROC == KMASTER) THEN DO JROC=1,NPROC IF (JROC == KMASTER) THEN ZRECVBUF(1:ISTOTAL) = RESHAPE(PSM,SHAPE(ZRECVBUF(1:ISTOTAL))) IRECVID = MYPROC IMSGLEN = ISTOTAL ELSE CALL MPL_RECV(ZRECVBUF(1:IBUFLENR),KTAG=ITAG,& &KFROM=IRECVID,CDSTRING='SPNORMC :') ENDIF CALL PE2SET(IRECVID,IA,IB,IRECVSETA,IRECVSETB) IRECVNUMP = D%NUMPP(IRECVSETA) IRECVFLD = IFLDR(IRECVSETB) IFLD = 0 DO JFLD=1,KFLD_G IF(KVSET(JFLD) == IRECVSETB) THEN IFLD=IFLD+1 DO JMLOC=1,IRECVNUMP IM = D%NALLMS(D%NPTRMS(IRECVSETA)-1+JMLOC) PGM(JFLD,IM) = ZRECVBUF((JMLOC-1)*IRECVFLD+IFLD) ENDDO ENDIF ENDDO ENDDO ENDIF ! Perform barrier synchronisation to guarantee all processors have ! completed communication IF( NPROC > 1 )THEN CALL MPL_BARRIER(CDSTRING='SPNORMC') ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SPNORMC END MODULE SPNORMC_MOD ectrans-1.8.0/src/trans/gpu/internal/write_legpol_mod.F900000775000175000017500000001265115174631767023534 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE WRITE_LEGPOL_MOD CONTAINS SUBROUTINE WRITE_LEGPOL USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT USE TPM_DISTR, ONLY: D, NPRTRV USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE TPM_FLT, ONLY: S USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE TPM_CTL, ONLY: C USE BYTES_IO_MOD, ONLY: JPBYTES_IO_SUCCESS, BYTES_IO_CLOSE, BYTES_IO_OPEN, BYTES_IO_WRITE !**** *WRITE_LEGPOL * - write out Leg.Pol. and assocciated arrays to file ! Purpose. ! -------- ! !** Interface. ! ---------- ! *CALL* *WRITE_LEGPOL* ! Explicit arguments : None ! -------------------- ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! ! ------- ! Mats Hamrud and Willem Deconinck *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 IMPLICIT NONE INTEGER(KIND=JPIM),PARAMETER :: JPIBUFL=4 INTEGER(KIND=JPIM) :: IRBYTES,IIBYTES,JMLOC,IPRTRV,IMLOC,IM,ILA,ILS,IFILE,JSETV INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IBUF(JPIBUFL),IDUM,JGL,II INTEGER(KIND=JPIM) :: IDGLU2 REAL(KIND=JPRBT) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,ALLOCATABLE :: IBUFA(:) ! ------------------------------------------------------------------ IRBYTES = 8 IIBYTES = 4 IDUM = 3141 IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_OPEN(IFILE,C%CLEGPOLFNAME,'W',IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_OPEN FAILED') ENDIF IBUF(1:2) = TRANSFER('LEGPOL ',IBUF(1:2)) IBUF(3) = R%NSMAX IBUF(4) = R%NDGNH CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_WRITE FAILED') ALLOCATE(IBUFA(2*R%NDGNH)) II = 0 DO JGL=1,R%NDGNH II = II+1 IBUFA(II) = G%NLOEN(JGL) II=II+1 IBUFA(II) = G%NMEN(JGL) ENDDO CALL BYTES_IO_WRITE(IFILE,IBUFA,2*R%NDGNH*IIBYTES,IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_WRITE FAILED') DEALLOCATE(IBUFA) DO JMLOC=1,D%NUMP,NPRTRV ! +++++++++++++++++++++ JMLOC LOOP ++++++++++ IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ! Anti-symmetric ISIZE = IDGLU*ILA IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(IMLOC)%RPNMA,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ! Symmetric ISIZE = IDGLU*ILS IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(IMLOC)%RPNMS,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ENDDO ENDDO ! Lat-lon grid IF(S%LDLL) THEN IBUF(:) = TRANSFER('LATLON---BEG-BEG',IBUF(1:4)) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IDGLU2 = S%NDGNHD IBUF(:) = (/IM,IDGLU,IDGLU2,IDUM/) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF ISIZE = 2*IDGLU*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(JMLOC)%RPNMWI,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ISIZE = 2*IDGLU2*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(JMLOC)%RPNMWO,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ENDDO ENDIF !End marker IBUF(:) = TRANSFER('LEGPOL---EOF-EOF',IBUF(1:4)) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_CLOSE(IFILE,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_CLOSE FAILED') ENDIF ENDIF END SUBROUTINE WRITE_LEGPOL END MODULE WRITE_LEGPOL_MOD ectrans-1.8.0/src/trans/gpu/internal/trltog_mod.F900000775000175000017500000010771215174631767022356 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRLTOG_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRLTOG, TRLTOG_HANDLE, PREPARE_TRLTOG TYPE TRLTOG_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HCOMBUFR_AND_COMBUFS END TYPE CONTAINS FUNCTION PREPARE_TRLTOG(ALLOCATOR,KF_FS,KF_GP) RESULT(HTRLTOG) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP, KF_FS TYPE(TRLTOG_HANDLE) :: HTRLTOG REAL(KIND=JPRBT) :: DUMMY INTEGER(KIND=JPIB) :: NELEM NELEM = 0 NELEM = NELEM + ALIGN(1_JPIB*KF_GP*D%NGPTOT*C_SIZEOF(DUMMY),128) ! ZCOMBUFR NELEM = NELEM + ALIGN(1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(DUMMY),128) !ZCOMBUFS upper obund HTRLTOG%HCOMBUFR_AND_COMBUFS = RESERVE(ALLOCATOR, NELEM, "HTRLTOG%HCOMBUFR_AND_COMBUFS") END FUNCTION PREPARE_TRLTOG SUBROUTINE TRLTOG(ALLOCATOR,HTRLTOG,PREEL_REAL,KF_FS,KF_GP,KF_UV_G,KF_SCALARS_G,KPTRGP,& & KVSETUV,KVSETSC,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *trltog * - transposition of grid point data from latitudinal ! to column structure. This takes place between inverse ! FFT and grid point calculations. ! TRLTOG is the inverse of TRGTOL ! Version using CUDA-aware MPI ! Purpose. ! -------- !** Interface. ! ---------- ! *call* *trltog(...) ! Explicit arguments : ! -------------------- ! PREEL_REAL - Latitudinal data ready for direct FFT (input) ! PGP - Blocked grid point data (output) ! KVSET - "v-set" for each field (input) ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! D.Dent : 97-08-04 Reorganisation to allow NPRTRV ! to differ from NPRGPEW ! =99-03-29= Mats Hamrud and Deborah Salmond ! JUMP in FFT's changed to 1 ! INDEX introduced and ZCOMBUF not used for same PE ! 01-11-23 Deborah Salmond and John Hague ! LIMP_NOOLAP Option for non-overlapping message passing ! and buffer packing ! 01-12-18 Peter Towers ! Improved vector performance of LTOG_PACK,LTOG_UNPACK ! 03-0-02 G. Radnoti: Call barrier always when nproc>1 ! 08-01-01 G.Mozdzynski: cleanup ! 09-01-02 G.Mozdzynski: use non-blocking recv and send ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_WAIT, MPL_BARRIER, MPL_ABORT, MPL_RECV, MPL_SEND USE TPM_GEN, ONLY: LSYNC_TRANS, NERR, LMPOFF USE EQ_REGIONS_MOD, ONLY: MY_REGION_EW, MY_REGION_NS USE TPM_DISTR, ONLY: D,MYSETV, MYSETW, MTAGLG,NPRCIDS,MYPROC,NPROC,NPRTRW,NPRTRV USE PE2SET_MOD, ONLY: PE2SET USE MPL_DATA_MODULE, ONLY: MPL_COMM_OML, JP_NON_BLOCKING_STANDARD USE OML_MOD, ONLY: OML_MY_THREAD USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS #ifdef USE_RAW_MPI USE MPI_F08, ONLY: MPI_COMM, MPI_REQUEST, MPI_REAL4, MPI_REAL8 ! Missing: MPI_ISEND, MPI_IRECV on purpose due to cray-mpi bug (see https://github.com/ecmwf-ifs/ectrans/pull/157) #endif USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE TPM_TRANS, ONLY: LDIVGP, LSCDERS, LUVDER, LVORGP, NPROMA USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_SIZEOF USE OPENACC_EXT, ONLY: EXT_ACC_ARR_DESC, EXT_ACC_PASS, EXT_ACC_CREATE, & & EXT_ACC_DELETE #ifdef ACCGPU USE OPENACC, ONLY: ACC_HANDLE_KIND #endif IMPLICIT NONE REAL(KIND=JPRBT), INTENT(INOUT), POINTER :: PREEL_REAL(:) INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G, KF_SCALARS_G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) 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(:) TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRLTOG_HANDLE) :: HTRLTOG ! LOCAL VARIABLES REAL(KIND=JPRBT), POINTER :: ZCOMBUFS(:),ZCOMBUFR(:) LOGICAL :: LLOCAL_CONTRIBUTION INTEGER(KIND=JPIB) :: ISENDTOT (NPROC) INTEGER(KIND=JPIB) :: IRECVTOT (NPROC) INTEGER(KIND=JPIM) :: ISENDTOT_MPI(NPROC) INTEGER(KIND=JPIM) :: IRECVTOT_MPI(NPROC) INTEGER(KIND=JPIM) :: IREQ (NPROC*2) INTEGER(KIND=JPIM) :: IRECV_TO_PROC(NPROC) INTEGER(KIND=JPIM) :: ISEND_TO_PROC(NPROC) INTEGER(KIND=JPIM) :: JFLD, J, JI, JGL, JK, JL, IFLDS, JROC, INR, INS INTEGER(KIND=JPIM) :: IFIRSTLAT, ILASTLAT, IFLD, IGL, IGLL,& &ISETA, ISETB, ISETV, ISEND, IRECV, ISETW, IPROC, & &IR, ILOCAL_LAT, ISEND_COUNTS, IRECV_COUNTS, IERROR, II, ILEN, & &JBLK, ILAT_STRIP INTEGER(KIND=JPIB) :: IPOS ! Contains FIELD, PARS, LEVS INTEGER(KIND=JPIM) :: IGP_OFFSETS(KF_GP,3) INTEGER(KIND=JPIM), PARAMETER :: IGP_OFFSETS_UV=1, IGP_OFFSETS_GP2=2, IGP_OFFSETS_GP3A=3, IGP_OFFSETS_GP3B=4 INTEGER(KIND=JPIM) :: IUVPAR,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IOFF INTEGER(KIND=JPIB) :: IIN_TO_SEND_BUFR(D%NLENGTF,2) INTEGER(KIND=JPIM) :: IIN_TO_SEND_BUFR_OFFSET(NPROC), IIN_TO_SEND_BUFR_V INTEGER(KIND=JPIM) :: IRECV_FIELD_COUNT(NPRTRV),IRECV_FIELD_COUNT_V INTEGER(KIND=JPIM) :: IRECV_WSET_SIZE(NPRTRW),IRECV_WSET_SIZE_V INTEGER(KIND=JPIM) :: IRECV_WSET_OFFSET(NPRTRW+1), IRECV_WSET_OFFSET_V INTEGER(KIND=JPIB), ALLOCATABLE :: ICOMBUFS_OFFSET(:),ICOMBUFR_OFFSET(:), IFLDA(:,:) INTEGER(KIND=JPIB) :: ICOMBUFS_OFFSET_V, ICOMBUFR_OFFSET_V INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: J3 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE TYPE(EXT_ACC_ARR_DESC) :: ACC_POINTERS(5) ! at most 5 copyins... INTEGER(KIND=JPIM) :: ACC_POINTERS_CNT #ifdef USE_RAW_MPI TYPE(MPI_COMM) :: LOCAL_COMM TYPE(MPI_REQUEST) :: IREQUEST(NPROC*2) #else INTEGER(KIND=JPIM) :: IREQUEST(NPROC*2) #endif #ifdef PARKINDTRANS_SINGLE #define TRLTOG_DTYPE MPI_REAL4 #else #define TRLTOG_DTYPE MPI_REAL8 #endif #ifdef USE_RAW_MPI IF(.NOT. LMPOFF) THEN LOCAL_COMM%MPI_VAL = MPL_COMM_OML( OML_MY_THREAD() ) ENDIF #endif ! ------------------------------------------------------------------ !* 0. Some initializations ! -------------------- IF (LHOOK) CALL DR_HOOK('TRLTOG',0,ZHOOK_HANDLE) ! Note we have either ! - KVSETUV and KVSETSC (with PGP, which has u, v, and scalar fields), or ! - KVSETUV, KVSETSC2, KVSETSC3A KVSETSC3B (with PGPUV, GP3A, PGP3B and PGP2) ! KVSETs are optionals. Their sizes canalso be inferred from KV_UV_G/KV_SCALARS_G (which ! should match PSPXXX and PGPXXX arrays) ! We first get the decomposition individually IVSETUV(:) = -1 IF (PRESENT(KVSETUV)) IVSETUV(:) = KVSETUV(:) IVSETSC(:)=-1 IF (PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF (PRESENT(KVSETSC2)) THEN IVSETSC(IOFF+1:IOFF+SIZE(KVSETSC2))=KVSETSC2(:) IOFF = IOFF+SIZE(KVSETSC2) ENDIF IF (PRESENT(KVSETSC3A)) THEN DO J3=1,MERGE(UBOUND(PGP3A,3),UBOUND(PGP3A,3)/3,.NOT. LSCDERS) IVSETSC(IOFF+1:IOFF+SIZE(KVSETSC3A))=KVSETSC3A(:) IOFF=IOFF+SIZE(KVSETSC3A) ENDDO ENDIF IF (PRESENT(KVSETSC3B)) THEN ! If SCDERS is on, the size of PGP is 3X larger because it is ! holding various derivatives. The problem is that those are ! at different non-contiguous positions, hence we treat them ! as separate fields DO J3=1,MERGE(UBOUND(PGP3B,3),UBOUND(PGP3B,3)/3,.NOT. LSCDERS) IVSETSC(IOFF+1:IOFF+SIZE(KVSETSC3B))=KVSETSC3B(:) IOFF=IOFF+SIZE(KVSETSC3B) ENDDO ENDIF IF (IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN CALL ABORT_TRANS("TRLTOG: Error in IVSETSC computation") ENDIF ENDIF ! Now from UV and Scalars decomposition we get the full decomposition IOFF=0 IF (KF_UV_G > 0) THEN IF (LVORGP) THEN IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) IOFF=IOFF+KF_UV_G ENDIF IF ( LDIVGP) THEN IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) IOFF=IOFF+KF_UV_G ENDIF IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) IOFF=IOFF+KF_UV_G IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) IOFF=IOFF+KF_UV_G ENDIF IF (KF_SCALARS_G > 0) THEN IVSET(IOFF+1:IOFF+KF_SCALARS_G) = IVSETSC(:) IOFF=IOFF+KF_SCALARS_G IF (LSCDERS) THEN IVSET(IOFF+1:IOFF+KF_SCALARS_G) = IVSETSC(:) IOFF=IOFF+KF_SCALARS_G ENDIF ENDIF IF (KF_UV_G > 0 .AND. LUVDER) THEN IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) IOFF=IOFF+KF_UV_G IVSET(IOFF+1:IOFF+KF_UV_G) = IVSETUV(:) IOFF=IOFF+KF_UV_G ENDIF IF (KF_SCALARS_G > 0) THEN IF (LSCDERS) THEN IVSET(IOFF+1:IOFF+KF_SCALARS_G) = IVSETSC(:) IOFF=IOFF+KF_SCALARS_G ENDIF ENDIF IF (.NOT. PRESENT(PGP)) THEN ! This is only relevant if we use the split interface (i.e. not PGP) IGP2PAR = 0 IGP3APAR = 0 IGP3ALEV = 0 IGP3BPAR = 0 IGP3BLEV = 0 IF (PRESENT(PGP2)) THEN IGP2PAR = UBOUND(PGP2,2) IF(LSCDERS) IGP2PAR = IGP2PAR/3 ENDIF IF (PRESENT(PGP3A)) THEN IGP3ALEV = UBOUND(PGP3A,2) IGP3APAR = UBOUND(PGP3A,3) IF(LSCDERS) IGP3APAR = IGP3APAR/3 ENDIF IF (PRESENT(PGP3B)) THEN IGP3BLEV = UBOUND(PGP3B,2) IGP3BPAR = UBOUND(PGP3B,3) IF(LSCDERS) IGP3BPAR = IGP3BPAR/3 ENDIF IF (IGP2PAR + IGP3ALEV*IGP3APAR + IGP3BPAR*IGP3BLEV /= KF_SCALARS_G) THEN WRITE(NERR,*) IGP2PAR, IGP3APAR, IGP3ALEV, IGP3BPAR, IGP3BLEV CALL ABORT_TRANS("INCONSISTENCY IN SCALARS") ENDIF ! This is only relevant if we use the split interface (i.e. not PGP) IUVPAR = 1 IOFF=1 IF(LVORGP) THEN IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) IUVPAR=IUVPAR+1 IOFF=IOFF+KF_UV_G ENDIF IF(LDIVGP) THEN IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) IUVPAR=IUVPAR+1 IOFF=IOFF+KF_UV_G ENDIF ! U IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) IUVPAR=IUVPAR+1 IOFF=IOFF+KF_UV_G ! V IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) IUVPAR=IUVPAR+1 IOFF=IOFF+KF_UV_G ! Scalars ! PGP2 IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,1) = IGP_OFFSETS_GP2 IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,2) = (/(J, J=1,IGP2PAR)/) IOFF=IOFF+IGP2PAR ! PGP3A IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,1) = IGP_OFFSETS_GP3A IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,2) = (/(1+J/IGP3ALEV, J=0,IGP3APAR*IGP3ALEV-1)/) IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,3) = (/(1+MOD(J,IGP3ALEV), J=0,IGP3APAR*IGP3ALEV-1)/) IOFF=IOFF+IGP3APAR*IGP3ALEV ! PGP3B IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,1) = IGP_OFFSETS_GP3B IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,2) = (/(1+J/IGP3BLEV, J=0,IGP3BPAR*IGP3BLEV-1)/) IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,3) = (/(1+MOD(J,IGP3BLEV), J=0,IGP3BPAR*IGP3BLEV-1)/) IOFF=IOFF+IGP3BPAR*IGP3BLEV IF(LSCDERS) THEN !Scalars NS Derivatives ! PGP2 IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,1) = IGP_OFFSETS_GP2 IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,2) = (/(J+IGP2PAR, J=1,IGP2PAR)/) IOFF=IOFF+IGP2PAR ! PGP3A IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,1) = IGP_OFFSETS_GP3A IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,2) = (/(1+IGP3APAR+J/IGP3ALEV, J=0,IGP3APAR*IGP3ALEV-1)/) IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,3) = (/(1+MOD(J,IGP3ALEV), J=0,IGP3APAR*IGP3ALEV-1)/) IOFF=IOFF+IGP3APAR*IGP3ALEV ! PGP3B IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,1) = IGP_OFFSETS_GP3B IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,2) = (/(1+IGP3BPAR+J/IGP3BLEV, J=0,IGP3BPAR*IGP3BLEV-1)/) IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,3) = (/(1+MOD(J,IGP3BLEV), J=0,IGP3BPAR*IGP3BLEV-1)/) IOFF=IOFF+IGP3BPAR*IGP3BLEV ENDIF IF(LUVDER) THEN ! U Derivative NS IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) IUVPAR=IUVPAR+1 IOFF=IOFF+KF_UV_G ! V Derivative NS IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,1) = IGP_OFFSETS_UV IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,2) = IUVPAR IGP_OFFSETS(IOFF:IOFF+KF_UV_G-1,3) = (/(J, J=1,KF_UV_G)/) IUVPAR=IUVPAR+1 IOFF=IOFF+KF_UV_G ENDIF IF(LSCDERS) THEN !Scalars NS Derivatives ! PGP2 IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,1) = IGP_OFFSETS_GP2 IGP_OFFSETS(IOFF:IOFF+IGP2PAR-1,2) = (/(J+2*IGP2PAR, J=1,IGP2PAR)/) IOFF=IOFF+IGP2PAR ! PGP3A IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,1) = IGP_OFFSETS_GP3A IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,2) = (/(1+2*IGP3APAR+J/IGP3ALEV, J=0,IGP3APAR*IGP3ALEV-1)/) IGP_OFFSETS(IOFF:IOFF+IGP3APAR*IGP3ALEV-1,3) = (/(1+MOD(J,IGP3ALEV), J=0,IGP3APAR*IGP3ALEV-1)/) IOFF=IOFF+IGP3APAR*IGP3ALEV ! PGP3B IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,1) = IGP_OFFSETS_GP3B IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,2) = (/(1+2*IGP3BPAR+J/IGP3BLEV, J=0,IGP3BPAR*IGP3BLEV-1)/) IGP_OFFSETS(IOFF:IOFF+IGP3BPAR*IGP3BLEV-1,3) = (/(1+MOD(J,IGP3BLEV), J=0,IGP3BPAR*IGP3BLEV-1)/) IOFF=IOFF+IGP3BPAR*IGP3BLEV ENDIF ENDIF CALL GSTATS(1806,0) ! Prepare receiver arrays ! find number of fields on a certain V-set IF(NPRTRV == 1) THEN ! This is needed because KVSET(JFLD) == -1 if there is only one V-set IRECV_FIELD_COUNT(1) = KF_GP ELSE IRECV_FIELD_COUNT(:) = 0 DO JFLD=1,KF_GP IRECV_FIELD_COUNT(IVSET(JFLD)) = IRECV_FIELD_COUNT(IVSET(JFLD)) + 1 ENDDO ENDIF ! find number of grid-points on a certain W-set that overlap with myself IRECV_WSET_SIZE(:) = 0 DO ILOCAL_LAT=D%NFRSTLAT(MY_REGION_NS),D%NLSTLAT(MY_REGION_NS) ILAT_STRIP = ILOCAL_LAT-D%NFRSTLAT(MY_REGION_NS)+D%NPTRFLOFF+1 IRECV_WSET_SIZE(D%NPROCL(ILOCAL_LAT)) = & & IRECV_WSET_SIZE(D%NPROCL(ILOCAL_LAT))+D%NONL(ILAT_STRIP,MY_REGION_EW) ENDDO ! sum up offsets IRECV_WSET_OFFSET(1) = 0 DO JROC=1,NPRTRW IRECV_WSET_OFFSET(JROC+1)=IRECV_WSET_OFFSET(JROC)+IRECV_WSET_SIZE(JROC) ENDDO DO JROC=1,NPROC CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) ! total recv size is # points per field * # fields IRECVTOT(JROC) = 1_JPIB*IRECV_WSET_SIZE(ISETW)*IRECV_FIELD_COUNT(ISETV) ENDDO ! Prepare sender arrays IIN_TO_SEND_BUFR_OFFSET(1) = 0 DO JROC=1,NPROC ! Get new offset to my current KINDEX entry IF (JROC > 1 .AND. KF_FS > 0) THEN IIN_TO_SEND_BUFR_OFFSET(JROC) = IIN_TO_SEND_BUFR_OFFSET(JROC-1)+ISENDTOT(JROC-1)/KF_FS ELSEIF (JROC > 1) THEN IIN_TO_SEND_BUFR_OFFSET(JROC) = IIN_TO_SEND_BUFR_OFFSET(JROC-1) ENDIF CALL PE2SET(JROC,ISETA,ISETB,ISETW,ISETV) ! MAX(Index of first fourier latitude for this W set, first latitude of a senders A set) ! i.e. we find the overlap between what we have on sender side (others A set) and the receiver ! (me, the W-set). Ideally those conincide, at least mostly. IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA)) ! MIN(Index of last fourier latitude for this W set, last latitude of a senders A set) ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA)) IPOS = 0 DO JGL=IFIRSTLAT,ILASTLAT ! get from "actual" latitude to the latitude strip offset IGL = JGL-D%NFRSTLAT(ISETA)+D%NPTRFRSTLAT(ISETA) ! get from "actual" latitude to the latitude offset IGLL = JGL-D%NPTRLS(MYSETW)+1 DO JL=1,D%NONL(IGL,ISETB) IPOS = IPOS+1 ! offset to first layer of this gridpoint IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_OFFSET(JROC)+IPOS,1) = & & 1_JPIB*KF_FS*D%NSTAGTF(IGLL)+(D%NSTA(IGL,ISETB)-1)+(JL-1) ! distance between two layers of this gridpoint IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_OFFSET(JROC)+IPOS,2) = & & D%NSTAGTF(IGLL+1)-D%NSTAGTF(IGLL) ENDDO ENDDO !we always receive the full fourier space ISENDTOT(JROC) = IPOS*KF_FS ENDDO LLOCAL_CONTRIBUTION = ISENDTOT(MYPROC) > 0 #ifdef OMPGPU !$OMP TARGET DATA MAP(TO:IGP_OFFSETS) #endif #ifdef ACCGPU !$ACC DATA COPYIN(IGP_OFFSETS) ASYNC(1) #endif ACC_POINTERS_CNT = 0 IF (PRESENT(PGP)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP) ENDIF IF (PRESENT(PGPUV)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGPUV) ENDIF IF (PRESENT(PGP2)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP2) ENDIF IF (PRESENT(PGP3A)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3A) ENDIF IF (PRESENT(PGP3B)) THEN ACC_POINTERS_CNT = ACC_POINTERS_CNT + 1 ACC_POINTERS(ACC_POINTERS_CNT) = EXT_ACC_PASS(PGP3B) ENDIF IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_CREATE(ACC_POINTERS(1:ACC_POINTERS_CNT), & #ifdef ACCGPU & STREAM=1_ACC_HANDLE_KIND) #endif #ifdef OMPGPU & STREAM=1) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP) IF(PRESENT(PGP)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGPUV) IF(PRESENT(PGPUV)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP2) IF(PRESENT(PGP2)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP3A) IF(PRESENT(PGP3A)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PGP3B) IF(PRESENT(PGP3B)) !$OMP TARGET DATA MAP(TO:IIN_TO_SEND_BUFR) MAP(PRESENT,ALLOC:PREEL_REAL) IF(KF_FS > 0) #endif #ifdef ACCGPU !$ACC DATA IF(PRESENT(PGP)) PRESENT(PGP) ASYNC(1) !$ACC DATA IF(PRESENT(PGPUV)) PRESENT(PGPUV) ASYNC(1) !$ACC DATA IF(PRESENT(PGP2)) PRESENT(PGP2) ASYNC(1) !$ACC DATA IF(PRESENT(PGP3A)) PRESENT(PGP3A) ASYNC(1) !$ACC DATA IF(PRESENT(PGP3B)) PRESENT(PGP3B) ASYNC(1) ! Present until self contribution and packing are done !$ACC DATA COPYIN(IIN_TO_SEND_BUFR) PRESENT(PREEL_REAL) IF(KF_FS > 0) ASYNC(1) #endif CALL GSTATS(1806,1) ! Figure out processes that send or recv something ISEND_COUNTS = 0 IRECV_COUNTS = 0 DO JROC=1,NPROC IF( JROC /= MYPROC) THEN IF(IRECVTOT(JROC) > 0) THEN ! I have to recv something, so let me store that IRECV_COUNTS = IRECV_COUNTS + 1 IRECV_TO_PROC(IRECV_COUNTS)=JROC ENDIF IF(ISENDTOT(JROC) > 0) THEN ! I have to send something, so let me store that ISEND_COUNTS = ISEND_COUNTS+1 ISEND_TO_PROC(ISEND_COUNTS)=JROC ENDIF ENDIF ENDDO ! ... build this data structure now during the MPI communication ! Allocate this buffer now. Add 1 for self contribution ALLOCATE(IFLDA(KF_GP,1+IRECV_COUNTS)) ! Copy local contribution IF(LLOCAL_CONTRIBUTION) THEN ! I have to send something to myself... ! Input is KF_GP fields. We find the resulting KF_FS fields. IFLDS = 0 DO JFLD=1,KF_GP IF(IVSET(JFLD) == MYSETV .OR. IVSET(JFLD) == -1) THEN IFLDS = IFLDS+1 IF(PRESENT(KPTRGP)) THEN IFLDA(IFLDS,1) = KPTRGP(JFLD) ELSE IFLDA(IFLDS,1) = JFLD ENDIF ENDIF ENDDO ENDIF DO INR=1,IRECV_COUNTS IRECV=IRECV_TO_PROC(INR) CALL PE2SET(IRECV,ISETA,ISETB,ISETW,ISETV) IFLDS = 0 DO JFLD=1,KF_GP IF(IVSET(JFLD) == ISETV .OR. IVSET(JFLD) == -1 ) THEN IFLDS = IFLDS+1 IF(PRESENT(KPTRGP)) THEN IFLDA(IFLDS,1+INR)=KPTRGP(JFLD) ELSE IFLDA(IFLDS,1+INR)=JFLD ENDIF ENDIF ENDDO ENDDO #ifdef OMPGPU !$OMP TARGET DATA MAP(TO:IFLDA) #endif #ifdef ACCGPU !$ACC DATA COPYIN(IFLDA) ASYNC(1) #endif ! Copy local contribution IF(LLOCAL_CONTRIBUTION) THEN CALL GSTATS(1604,0) IRECV_WSET_OFFSET_V = IRECV_WSET_OFFSET(MYSETW) IRECV_WSET_SIZE_V = IRECV_WSET_SIZE(MYSETW) IIN_TO_SEND_BUFR_V = IIN_TO_SEND_BUFR_OFFSET(MYPROC) IF (PRESENT(PGP)) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) & !$OMP& PRIVATE(JK,JBLK,IFLD,IPOS) & !$OMP& SHARED(KF_FS,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V,IFLDA,IIN_TO_SEND_BUFR_V, & !$OMP& IIN_TO_SEND_BUFR,PREEL_REAL,PGP) & !$OMP& MAP(TO:KF_FS,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V,IIN_TO_SEND_BUFR_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS) & !$ACC& FIRSTPRIVATE(KF_FS,IRECV_WSET_SIZE_V,IRECV_WSET_OFFSET_V, & !$ACC& IIN_TO_SEND_BUFR_V,NPROMA) ASYNC(1) #endif DO JFLD=1,KF_FS DO JL=1,IRECV_WSET_SIZE_V JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD = IFLDA(JFLD,1) IPOS = IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,1)+ & & (JFLD-1)*IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,2)+1 PGP(JK,IFLD,JBLK) = PREEL_REAL(IPOS) ENDDO ENDDO ELSE #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) & !$OMP& PRIVATE(JK,JBLK,IFLD,IPOS) & !$OMP& SHARED(KF_FS,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V,IFLDA,IIN_TO_SEND_BUFR_V, & !$OMP& IIN_TO_SEND_BUFR,IGP_OFFSETS,PREEL_REAL,PGPUV,PGP2,PGP3A,PGP3B) & !$OMP& MAP(TO:KF_FS,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V,IIN_TO_SEND_BUFR_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,IPOS) & !$ACC& FIRSTPRIVATE(KF_FS,IRECV_WSET_SIZE_V,IRECV_WSET_OFFSET_V, & !$ACC& IIN_TO_SEND_BUFR_V,NPROMA) ASYNC(1) #endif DO JFLD=1,KF_FS DO JL=1,IRECV_WSET_SIZE_V JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD = IFLDA(JFLD,1) IPOS = IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,1)+ & & (JFLD-1)*IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,2)+1 IF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_UV) THEN PGPUV(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = PREEL_REAL(IPOS) ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP2) THEN PGP2(JK,IGP_OFFSETS(IFLD,2),JBLK)=PREEL_REAL(IPOS) ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3A) THEN PGP3A(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = PREEL_REAL(IPOS) ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3B) THEN PGP3B(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = PREEL_REAL(IPOS) ENDIF ENDDO ENDDO ENDIF CALL GSTATS(1604,1) ENDIF ALLOCATE(ICOMBUFS_OFFSET(ISEND_COUNTS+1)) ICOMBUFS_OFFSET(1) = 0 DO JROC=1,ISEND_COUNTS ICOMBUFS_OFFSET(JROC+1) = ICOMBUFS_OFFSET(JROC) + ISENDTOT(ISEND_TO_PROC(JROC)) ENDDO ALLOCATE(ICOMBUFR_OFFSET(IRECV_COUNTS+1)) ICOMBUFR_OFFSET(1) = 0 DO JROC=1,IRECV_COUNTS ICOMBUFR_OFFSET(JROC+1) = ICOMBUFR_OFFSET(JROC) + IRECVTOT(IRECV_TO_PROC(JROC)) ENDDO IF (IRECV_COUNTS > 0) THEN CALL ASSIGN_PTR(ZCOMBUFR, GET_ALLOCATION(ALLOCATOR, HTRLTOG%HCOMBUFR_AND_COMBUFS),& & 1_JPIB, ICOMBUFR_OFFSET(IRECV_COUNTS+1)*C_SIZEOF(ZCOMBUFR(1))) ENDIF IF (ISEND_COUNTS > 0) THEN CALL ASSIGN_PTR(ZCOMBUFS, GET_ALLOCATION(ALLOCATOR, HTRLTOG%HCOMBUFR_AND_COMBUFS),& & ALIGN(1_JPIB*KF_GP*D%NGPTOT*C_SIZEOF(ZCOMBUFR(1)),128)+1, & & ICOMBUFS_OFFSET(ISEND_COUNTS+1)*C_SIZEOF(ZCOMBUFS(1))) ENDIF #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:ZCOMBUFS) IF(ISEND_COUNTS > 0) #endif #ifdef ACCGPU !$ACC DATA PRESENT(ZCOMBUFS) IF(ISEND_COUNTS > 0) ASYNC(1) #endif CALL GSTATS(1605,0) DO INS=1,ISEND_COUNTS IPROC = ISEND_TO_PROC(INS) ILEN = ISENDTOT(IPROC)/KF_FS IIN_TO_SEND_BUFR_V = IIN_TO_SEND_BUFR_OFFSET(IPROC) ICOMBUFS_OFFSET_V = ICOMBUFS_OFFSET(INS) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) & !$OMP& PRIVATE(IPOS) & !$OMP& SHARED(KF_FS,ILEN,IIN_TO_SEND_BUFR_V,IIN_TO_SEND_BUFR,PREEL_REAL,ICOMBUFS_OFFSET_V, & !$OMP& ZCOMBUFS) & !$OMP& MAP(TO:KF_FS,ILEN,IIN_TO_SEND_BUFR_V,ICOMBUFS_OFFSET_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) PRIVATE(IPOS) FIRSTPRIVATE(KF_FS,ILEN,IIN_TO_SEND_BUFR_V, & !$ACC& ICOMBUFS_OFFSET_V) COLLAPSE(2) ASYNC(1) #endif DO JFLD=1,KF_FS DO JL=1,ILEN IPOS = IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,1)+ & & (JFLD-1)*IIN_TO_SEND_BUFR(IIN_TO_SEND_BUFR_V+JL,2)+1 ZCOMBUFS(ICOMBUFS_OFFSET_V+(JFLD-1)*ILEN+JL) = PREEL_REAL(IPOS) ENDDO ENDDO ENDDO CALL GSTATS(1605,1) #ifdef OMPGPU !$OMP END TARGET DATA ! ZCOMBUFS #endif #ifdef ACCGPU !$ACC END DATA ! ZCOMBUFS !$ACC WAIT(1) #endif CALL GSTATS(805,0) IF (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(421,0) IR=0 !...Receive loop......................................................... #ifdef USE_GPU_AWARE_MPI #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_PTR(ZCOMBUFS,ZCOMBUFR) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZCOMBUFS,ZCOMBUFR) #endif #else #ifdef OMPGPU !$OMP TARGET UPDATE FROM(ZCOMBUFS) IF(ISEND_COUNTS > 0) #endif #ifdef ACCGPU !! this is safe-but-slow fallback for running without GPU-aware MPI !$ACC UPDATE HOST(ZCOMBUFS) IF(ISEND_COUNTS > 0) #endif #endif ! Skip the own contribution because this is ok to overflow ISENDTOT(MYPROC) = 0 IRECVTOT(MYPROC) = 0 ISENDTOT_MPI = ISENDTOT IRECVTOT_MPI = IRECVTOT IF (ANY(ISENDTOT_MPI /= ISENDTOT)) & & CALL MPL_ABORT("Overflow in trltog") IF (ANY(IRECVTOT_MPI /= IRECVTOT)) & & CALL MPL_ABORT("Overflow in trltog") DO INR=1,IRECV_COUNTS IR=IR+1 IRECV=IRECV_TO_PROC(INR) #ifdef USE_RAW_MPI CALL MPI_IRECV(ZCOMBUFR(ICOMBUFR_OFFSET(INR)+1:ICOMBUFR_OFFSET(INR+1)), & & IRECVTOT_MPI(IRECV), & & TRLTOG_DTYPE,NPRCIDS(IRECV)-1, & & MTAGLG, LOCAL_COMM, IREQUEST(IR), & & IERROR ) IREQ(IR) = IREQUEST(IR)%MPI_VAL #else CALL MPL_RECV(ZCOMBUFR(ICOMBUFR_OFFSET(INR)+1:ICOMBUFR_OFFSET(INR+1)), & & KSOURCE=NPRCIDS(IRECV), KTAG=MTAGLG, KMP_TYPE=JP_NON_BLOCKING_STANDARD, & & KREQUEST=IREQUEST(IR)) IREQ(IR) = IREQUEST(IR) #endif ENDDO !...Send loop......................................................... DO INS=1,ISEND_COUNTS IR=IR+1 ISEND=ISEND_TO_PROC(INS) #ifdef USE_RAW_MPI CALL MPI_ISEND(ZCOMBUFS(ICOMBUFS_OFFSET(INS)+1:ICOMBUFS_OFFSET(INS+1)),ISENDTOT_MPI(ISEND), & & TRLTOG_DTYPE, NPRCIDS(ISEND)-1,MTAGLG,LOCAL_COMM,IREQUEST(IR),IERROR) IREQ(IR) = IREQUEST(IR)%MPI_VAL #else CALL MPL_SEND(ZCOMBUFS(ICOMBUFS_OFFSET(INS)+1:ICOMBUFS_OFFSET(INS+1)), & & KDEST=NPRCIDS(ISEND), KTAG=MTAGLG, KMP_TYPE=JP_NON_BLOCKING_STANDARD, & & KREQUEST=IREQUEST(IR)) IREQ(IR) = IREQUEST(IR) #endif ENDDO IF(IR > 0) THEN CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & & CDSTRING='TRLTOG: WAIT FOR SENDS AND RECEIVES') ENDIF #ifdef USE_GPU_AWARE_MPI #ifdef ACCGPU !$ACC END HOST_DATA ! ZCOMBUFS, ZCOMBUFR #endif #ifdef OMPGPU !$OMP END TARGET DATA ! ZCOMBUFS, ZCOMBUFR #endif #else #ifdef OMPGPU #endif !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE TO(ZCOMBUFR) IF(IRECV_COUNTS > 0) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(ZCOMBUFR) IF(IRECV_COUNTS > 0) #endif #endif IF (LSYNC_TRANS) THEN CALL GSTATS(441,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(441,1) ENDIF CALL GSTATS(421,1) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:ZCOMBUFR) IF(IRECV_COUNTS > 0) #endif #ifdef ACCGPU !$ACC DATA PRESENT(ZCOMBUFR) IF(IRECV_COUNTS > 0) ASYNC(1) #endif CALL GSTATS(805,1) ! Unpack loop......................................................... CALL GSTATS(1606,0) DO INR=1,IRECV_COUNTS IRECV=IRECV_TO_PROC(INR) CALL PE2SET(IRECV,ISETA,ISETB,ISETW,ISETV) IRECV_FIELD_COUNT_V = IRECV_FIELD_COUNT(ISETV) ICOMBUFR_OFFSET_V = ICOMBUFR_OFFSET(INR) IRECV_WSET_OFFSET_V = IRECV_WSET_OFFSET(ISETW) IRECV_WSET_SIZE_V = IRECV_WSET_SIZE(ISETW) IF (PRESENT(PGP)) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) & !$OMP& PRIVATE(JK,JBLK,IFLD,JI) & !$OMP& SHARED(IRECV_FIELD_COUNT_V,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V,IFLDA, & !$OMP& ICOMBUFR_OFFSET_V,ZCOMBUFR,PGP,INR) & !$OMP& MAP(TO:IRECV_FIELD_COUNT_V,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V, & !$OMP& ICOMBUFR_OFFSET_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI) & !$ACC& FIRSTPRIVATE(INR,IRECV_FIELD_COUNT_V,IRECV_WSET_SIZE_V,& !$ACC& IRECV_WSET_OFFSET_V,NPROMA,ICOMBUFR_OFFSET_V) ASYNC(1) #endif DO JFLD=1,IRECV_FIELD_COUNT_V DO JL=1,IRECV_WSET_SIZE_V JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD=IFLDA(JFLD,1+INR) JI = ICOMBUFR_OFFSET_V+(JFLD-1)*IRECV_WSET_SIZE_V+JL PGP(JK,IFLD,JBLK) = ZCOMBUFR(JI) ENDDO ENDDO ELSE #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) & !$OMP& PRIVATE(JK,JBLK,IFLD,JI) & !$OMP& SHARED(IRECV_FIELD_COUNT_V,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V,IFLDA, & !$OMP& ICOMBUFR_OFFSET_V,IGP_OFFSETS,ZCOMBUFR,PGPUV,PGP2,PGP3A,PGP3B,INR) & !$OMP& MAP(TO:IRECV_FIELD_COUNT_V,IRECV_WSET_SIZE_V,NPROMA,IRECV_WSET_OFFSET_V, & !$OMP& ICOMBUFR_OFFSET_V) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) DEFAULT(NONE) PRIVATE(JK,JBLK,IFLD,JI) & !$ACC& FIRSTPRIVATE(INR,IRECV_FIELD_COUNT_V,IRECV_WSET_SIZE_V, & !$ACC& IRECV_WSET_OFFSET_V,NPROMA,ICOMBUFR_OFFSET_V) ASYNC(1) #endif DO JFLD=1,IRECV_FIELD_COUNT_V DO JL=1,IRECV_WSET_SIZE_V JK = MOD(IRECV_WSET_OFFSET_V+JL-1,NPROMA)+1 JBLK = (IRECV_WSET_OFFSET_V+JL-1)/NPROMA+1 IFLD=IFLDA(JFLD,1+INR) JI = ICOMBUFR_OFFSET_V+(JFLD-1)*IRECV_WSET_SIZE_V+JL IF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_UV) THEN PGPUV(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP2) THEN PGP2(JK,IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3A) THEN PGP3A(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) ELSEIF(IGP_OFFSETS(IFLD,1) == IGP_OFFSETS_GP3B) THEN PGP3B(JK,IGP_OFFSETS(IFLD,3),IGP_OFFSETS(IFLD,2),JBLK) = ZCOMBUFR(JI) ENDIF ENDDO ENDDO ENDIF ENDDO #ifdef OMPGPU #endif #ifdef ACCGPU !$ACC WAIT(1) #endif #ifdef OMPGPU !$OMP END TARGET DATA ! ZCOMBUFR #endif #ifdef ACCGPU !$ACC END DATA ! ZCOMBUFR #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(440,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(422,0) #ifdef OMPGPU !$OMP END TARGET DATA ! IFLDA !$OMP END TARGET DATA ! PREEL_REAL !$OMP END TARGET DATA ! PGP3B !$OMP END TARGET DATA ! PGP3A !$OMP END TARGET DATA ! PGP2 !$OMP END TARGET DATA ! PGPUV !$OMP END TARGET DATA ! PGP #endif #ifdef ACCGPU !$ACC END DATA ! IFLDA !$ACC END DATA ! PREEL_REAL !$ACC END DATA ! PGP3B !$ACC END DATA ! PGP3A !$ACC END DATA ! PGP2 !$ACC END DATA ! PGPUV !$ACC END DATA ! PGP #endif IF (PRESENT(PGP)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PGP) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PGP) ASYNC(1) #endif ENDIF IF (PRESENT(PGPUV)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PGPUV) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PGPUV) ASYNC(1) #endif ENDIF IF (PRESENT(PGP2)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PGP2) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PGP2) ASYNC(1) #endif ENDIF IF (PRESENT(PGP3A)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PGP3A) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PGP3A) ASYNC(1) #endif ENDIF IF (PRESENT(PGP3B)) THEN #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PGP3B) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PGP3B) ASYNC(1) #endif ENDIF IF (ACC_POINTERS_CNT > 0) CALL EXT_ACC_DELETE(ACC_POINTERS(1:ACC_POINTERS_CNT), & #ifdef ACCGPU & STREAM=1_ACC_HANDLE_KIND) #endif #ifdef OMPGPU & STREAM=1) #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(442,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(442,1) ENDIF CALL GSTATS(422,1) #ifdef ACCGPU !$ACC END DATA ! IGP_OFFSETS !$ACC WAIT(1) #endif #ifdef OMPGPU !$OMP END TARGET DATA !IGP_OFFSETS #endif CALL GSTATS(1606,1) ! Free this now DEALLOCATE(IFLDA) IF (LHOOK) CALL DR_HOOK('TRLTOG',1,ZHOOK_HANDLE) END SUBROUTINE TRLTOG END MODULE TRLTOG_MOD ectrans-1.8.0/src/trans/gpu/internal/prfi1b_mod.F900000775000175000017500000001027015174631767022216 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE PRFI1B_MOD CONTAINS SUBROUTINE PRFI1B(PIA,PSPEC,KFIELDS,KDIM,KFLDPTR) USE PARKIND1, ONLY: JPIM, JPRB USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1B(...)* ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPEC - spectral array ! KFIELDS - number of fields ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1B in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM) :: KM,KMLOC REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PIA(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDIM INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: INM, IR, JN, JFLD, IASM0 ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- ASSOCIATE(D_NUMP=>D%NUMP, D_MYMS=>D%MYMS, D_NASM0=>D%NASM0, R_NSMAX=>R%NSMAX) #ifdef ACCGPU !$ACC DATA PRESENT(D,D_NUMP,R,R_NSMAX,D_MYMS,D_NASM0,PIA,PSPEC) ASYNC(1) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:D,D_NUMP,R,R_NSMAX,D_MYMS,D_NASM0,PIA,PSPEC) #endif IF(PRESENT(KFLDPTR)) THEN CALL ABORT_TRANS("KFLDPTR not implemented for GPU") ELSE !loop over wavenumber #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(KM,IASM0,INM) SHARED(KFIELDS,KDIM,D,R,PIA,PSPEC) MAP(TO:KFIELDS) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,IASM0,INM) & !$ACC FIRSTPRIVATE(KFIELDS,KDIM) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=0,R_NSMAX+3 DO JFLD=1,KFIELDS KM = D_MYMS(KMLOC) IF (JN <= 1) THEN PIA(2*JFLD-1,JN+1,KMLOC) = 0.0_JPRB PIA(2*JFLD ,JN+1,KMLOC) = 0.0_JPRB ELSEIF (JN <= R_NSMAX+2-KM) THEN IASM0 = D_NASM0(KM) INM = IASM0+((R_NSMAX+2-JN)-KM)*2 PIA(2*JFLD-1,JN+1,KMLOC) = PSPEC(JFLD,INM ) PIA(2*JFLD ,JN+1,KMLOC) = PSPEC(JFLD,INM+1) ELSEIF (JN <= R_NSMAX+3-KM) THEN PIA(2*JFLD-1,JN+1,KMLOC) = 0.0_JPRB PIA(2*JFLD ,JN+1,KMLOC) = 0.0_JPRB ENDIF ENDDO ENDDO ENDDO ENDIF #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE PRFI1B END MODULE PRFI1B_MOD ectrans-1.8.0/src/trans/gpu/internal/trltom_mod.F900000775000175000017500000002047215174631767022361 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRLTOM_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRLTOM, PREPARE_TRLTOM, TRLTOM_HANDLE TYPE TRLTOM_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPFBUF END TYPE CONTAINS FUNCTION PREPARE_TRLTOM(ALLOCATOR, KF_FS) RESULT(HTRLTOM) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(TRLTOM_HANDLE) :: HTRLTOM REAL(KIND=JPRBT) :: DUMMY HTRLTOM%HPFBUF = RESERVE(ALLOCATOR, 2_JPIB*D%NLENGT1B*KF_FS*C_SIZEOF(DUMMY), "HTRLTOM%HPFBUF") END FUNCTION SUBROUTINE TRLTOM(ALLOCATOR,HTRLTOM,PFBUF_IN,PFBUF,KF_FS) !**** *TRLTOM * - transposition in Fourierspace ! Purpose. ! -------- ! Transpose Fourier coefficients from partitioning ! over latitudes to partitioning over wave numbers ! This is done between inverse Legendre Transform ! and inverse FFT. ! This is the inverse routine of TRMTOL. !** Interface. ! ---------- ! *CALL* *TRLTOM(...)* ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is ! -------------------- used for both input and output. ! KF_FS - Number of fields communicated ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified : 97-06-18 G. Mozdzynski - control MPI mailbox use ! (NCOMBFLEN) for nphase.eq.1 ! Modified : 99-05-28 D.Salmond - Optimise copies. ! Modified : 00-02-02 M.Hamrud - Remove NPHASE ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message ! passing and buffer packing ! G.Mozdzynski: 08-01-01 Cleanup ! Y.Seity : 07-08-30 Add barrier synchronisation under LSYNC_TRANS ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK, MPL_ALLTOALLV USE TPM_DISTR, ONLY: D, NPRTRW, NPROC, MYSETW USE TPM_GEN, ONLY: LSYNC_TRANS, NERR, LMPOFF #ifdef USE_RAW_MPI USE MPI_F08, ONLY: MPI_COMM, MPI_REAL4, MPI_REAL8 ! Missing: MPI_ALLTOALLV on purpose due to cray-mpi bug (see https://github.com/ecmwf-ifs/ectrans/pull/157) #endif USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_SIZEOF USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS REAL(KIND=JPRBT) ,INTENT(OUT), POINTER :: PFBUF(:) REAL(KIND=JPRBT) ,INTENT(INOUT), POINTER :: PFBUF_IN(:) INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) INTEGER(KIND=JPIM) :: J, FROM_SEND, TO_SEND, FROM_RECV, TO_RECV, IRANK INTEGER(KIND=JPIB) :: JPOS, ISTA, IEND, ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IERROR TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRLTOM_HANDLE), INTENT(IN) :: HTRLTOM #ifdef USE_RAW_MPI TYPE(MPI_COMM) :: LOCAL_COMM #endif #ifdef PARKINDTRANS_SINGLE #define TRLTOM_DTYPE MPI_REAL4 #else #define TRLTOM_DTYPE MPI_REAL8 #endif #ifdef USE_RAW_MPI IF(.NOT. LMPOFF) THEN LOCAL_COMM%MPI_VAL = MPL_ALL_MS_COMM ENDIF #endif IF (LHOOK) CALL DR_HOOK('TRLTOM',0,ZHOOK_HANDLE) CALL ASSIGN_PTR(PFBUF, GET_ALLOCATION(ALLOCATOR, HTRLTOM%HPFBUF),& & 1_JPIB, 2_JPIB*D%NLENGT1B*KF_FS*C_SIZEOF(PFBUF(1))) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PFBUF,PFBUF_IN) #endif #ifdef ACCGPU !$ACC DATA PRESENT(PFBUF,PFBUF_IN) #endif IF(NPROC > 1) THEN DO J=1,NPRTRW ILENS(J) = D%NLTSGTB(J)*2*KF_FS IOFFS(J) = D%NSTAGT0B(J)*2*KF_FS ILENR(J) = D%NLTSFTB(J)*2*KF_FS IOFFR(J) = D%NSTAGT1B(J)*2*KF_FS ENDDO CALL GSTATS(806,0) ! copy to self workaround IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) IF (ILENS(IRANK) /= ILENR(IRANK)) THEN WRITE(NERR,*) "ERROR", ILENS(IRANK), ILENR(IRANK) CALL ABORT_TRANS("TRLTOM: Error - ILENS(IRANK) /= ILENR(IRANK)") ENDIF IF (ILENS(IRANK) > 0) THEN FROM_SEND = IOFFS(IRANK) + 1 TO_SEND = FROM_SEND + ILENS(IRANK) - 1 FROM_RECV = IOFFR(IRANK) + 1 TO_RECV = FROM_RECV + ILENR(IRANK) - 1 #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) SHARED(PFBUF,PFBUF_IN,FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) DO JPOS=FROM_SEND,TO_SEND PFBUF(JPOS-FROM_SEND+FROM_RECV) = PFBUF_IN(JPOS) ENDDO !$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO #endif #ifdef ACCGPU !$ACC KERNELS ASYNC(1) PFBUF(FROM_RECV:TO_RECV) = PFBUF_IN(FROM_SEND:TO_SEND) !$ACC END KERNELS #endif ILENS(IRANK) = 0 ILENR(IRANK) = 0 ENDIF IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(411,0) #ifdef USE_GPU_AWARE_MPI #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PFBUF_IN,PFBUF) #endif #endif #ifdef USE_RAW_MPI CALL MPI_ALLTOALLV(PFBUF_IN,ILENS,IOFFS,TRLTOM_DTYPE,& & PFBUF,ILENR,IOFFR, TRLTOM_DTYPE, & & LOCAL_COMM,IERROR) #else CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN, KSENDCOUNTS=ILENS, PRECVBUF=PFBUF, KRECVCOUNTS=ILENR, & & KSENDDISPL=IOFFS, KRECVDISPL=IOFFR, KCOMM=MPL_ALL_MS_COMM, & & CDSTRING='TRLTOM:') #endif #ifdef USE_GPU_AWARE_MPI #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END HOST_DATA #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE TO(PFBUF) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PFBUF) #endif #endif IF (LSYNC_TRANS) THEN CALL GSTATS(431,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(431,1) ENDIF CALL GSTATS(411,1) #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(806,1) ELSE ILEN = 2_JPIB*D%NLTSGTB(MYSETW)*KF_FS ISTA = 2_JPIB*D%NSTAGT1B(MYSETW)*KF_FS+1 IEND = ISTA+ILEN-1 CALL GSTATS(1607,0) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) SHARED(IEND,ISTA,PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) FIRSTPRIVATE(ISTA,IEND) #endif DO JPOS=ISTA,IEND PFBUF(JPOS) = PFBUF_IN(JPOS) ENDDO CALL GSTATS(1607,1) ENDIF #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('TRLTOM',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRLTOM END MODULE TRLTOM_MOD ectrans-1.8.0/src/trans/gpu/internal/spnormd_mod.F900000775000175000017500000000312515174631767022516 0ustar alastairalastair! (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. ! MODULE SPNORMD_MOD CONTAINS SUBROUTINE SPNORMD(PSPEC,KFLD,PMET,PSM) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D ! IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) REAL(KIND=JPRBT) ,INTENT(IN) :: PMET(0:R%NSMAX) INTEGER(KIND=JPIM) ,INTENT(IN) :: KFLD REAL(KIND=JPRBT) ,INTENT(OUT) :: PSM(:,:) INTEGER(KIND=JPIM) :: JM ,JFLD ,JN ,IM ,ISP ! ------------------------------------------------------------------ CALL GSTATS(1651,0) !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JM,IM,JN,ISP,JFLD) DO JM=1,D%NUMP PSM(:,JM) = 0.0_JPRBT IM = D%MYMS(JM) IF(IM == 0)THEN DO JN=0,R%NSMAX ISP = D%NASM0(0)+JN*2 DO JFLD=1,KFLD PSM(JFLD,JM) = PSM(JFLD,JM)+PMET(JN)*PSPEC(JFLD,ISP)**2 ENDDO ENDDO ELSE DO JN=IM,R%NSMAX ISP = D%NASM0(IM)+(JN-IM)*2 DO JFLD=1,KFLD PSM(JFLD,JM) = PSM(JFLD,JM)+2.0_JPRBT*PMET(JN)*& &(PSPEC(JFLD,ISP)**2+PSPEC(JFLD,ISP+1)**2) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1651,1) ! ------------------------------------------------------------------ END SUBROUTINE SPNORMD END MODULE SPNORMD_MOD ectrans-1.8.0/src/trans/gpu/internal/sump_trans_mod.F900000775000175000017500000002436715174631767023242 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE SUMP_TRANS_MOD CONTAINS SUBROUTINE SUMP_TRANS ! Set up distributed environment for the transform package (part 2) ! Modifications : ! P.Marguinaud : 11-Sep-2012 : Fix twice allocated pointer USE EC_PARKIND ,ONLY : JPIM ,JPRD, JPIB USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, MYSETW, NPRTRNS, NPRTRW, NPROC, MYPROC USE SUMPLATF_MOD ,ONLY : SUMPLATF USE SUMPLAT_MOD ,ONLY : SUMPLAT USE SUSTAONL_MOD ,ONLY : SUSTAONL USE MYSENDSET_MOD ,ONLY : MYSENDSET USE MYRECVSET_MOD ,ONLY : MYRECVSET USE EQ_REGIONS_MOD ,ONLY : MY_REGION_NS, MY_REGION_EW, & & N_REGIONS, N_REGIONS_EW, N_REGIONS_NS ! IMPLICIT NONE INTEGER(KIND=JPIM) :: JM INTEGER(KIND=JPIM) :: JGL,IGL,IPLAT,ISENDSET,IRECVSET,JML,IPOS,IM INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF,KMLOC,KM INTEGER(KIND=JPIB) :: OFFSET1,OFFSET2,OFFSET3 INTEGER(KIND=JPIM),ALLOCATABLE :: IGPTOTL(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZDUM(:) REAL(KIND=JPRD) :: ZMEDIAP LOGICAL :: LLP1,LLP2 ! ------------------------------------------------------------------ LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUMP_TRANS ===' IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NULTPP(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NULTPP ',SIZE(D%NULTPP ),SHAPE(D%NULTPP ) ALLOCATE(D%NPTRLS(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLS ',SIZE(D%NPTRLS ),SHAPE(D%NPTRLS ) ALLOCATE(D%NPROCL(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCL ',SIZE(D%NPROCL ),SHAPE(D%NPROCL ) CALL SUMPLATF(R%NDGL,NPRTRNS,MYSETW,D%NULTPP,D%NPROCL,D%NPTRLS) D%NDGL_FS = D%NULTPP(MYSETW) ! Help arrays for spectral to fourier space transposition ALLOCATE(D%NLTSGTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSGTB ',SIZE(D%NLTSGTB),SHAPE(D%NLTSGTB) ALLOCATE(D%NLTSFTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSFTB ',SIZE(D%NLTSFTB),SHAPE(D%NLTSFTB) ALLOCATE(D%NSTAGT0B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT0B ',SIZE(D%NSTAGT0B),SHAPE(D%NSTAGT0B) ALLOCATE(D%NSTAGT1B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT1B ',SIZE(D%NSTAGT1B),SHAPE(D%NSTAGT1B) ALLOCATE(D%MSTABF (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%MSTABF ',SIZE(D%MSTABF),SHAPE(D%MSTABF) D%NLTSGTB(:) = 0 DO JGL=1,D%NDGL_FS IGL = D%NPTRLS(MYSETW)+JGL-1 DO JM=0,G%NMEN(IGL) D%NLTSGTB(D%NPROCM(JM)) = D%NLTSGTB(D%NPROCM(JM))+1 ENDDO ENDDO DO JA=1,NPRTRW IPLAT = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA)+JGL-1 DO JM=1,D%NUMP IF(IGL > R%NDGNH-G%NDGLU(D%MYMS(JM)) .AND. IGL <= R%NDGNH+G%NDGLU(D%MYMS(JM))) THEN IPLAT = IPLAT + 1 ENDIF ENDDO ENDDO D%NLTSFTB(JA) = IPLAT ENDDO DO JA=1,NPRTRW-1 ISENDSET = MYSENDSET(NPRTRW,MYSETW,JA) IRECVSET = MYRECVSET(NPRTRW,MYSETW,JA) D%MSTABF(IRECVSET) = ISENDSET ENDDO D%MSTABF(MYSETW) = MYSETW ALLOCATE(D%NPNTGTB0(0:R%NSMAX,D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB0 ',SIZE(D%NPNTGTB0 ),SHAPE(D%NPNTGTB0 ) ALLOCATE(D%NPNTGTB1(D%NUMP,R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB1 ',SIZE(D%NPNTGTB1 ),SHAPE(D%NPNTGTB1 ) ! Global offsets of processors D%NSTAGT0B(1) = 0 D%NSTAGT1B(1) = 0 DO JA=2,NPRTRNS D%NSTAGT0B(JA) = D%NSTAGT0B(JA-1)+D%NLTSGTB(JA-1) D%NSTAGT1B(JA) = D%NSTAGT1B(JA-1)+D%NLTSFTB(JA-1) ENDDO ! Global size of foubuf D%NLENGT0B = D%NSTAGT0B(NPRTRNS)+D%NLTSGTB(NPRTRNS) D%NLENGT1B = D%NSTAGT1B(NPRTRNS)+D%NLTSFTB(NPRTRNS) ! Global offsets of grid points DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(MYSETW) IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JML=D%NPTRMS(JA),D%NPTRMS(JA)+D%NUMPP(JA)-1 IM = D%NALLMS(JML) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB0(IM,JGL) = D%NSTAGT0B(D%NPROCM(IM)) + IPOS IPOS = IPOS+1 ELSE D%NPNTGTB0(IM,JGL) = -99 ENDIF ENDDO ENDDO ENDDO DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA) + JGL - 1 DO JM=1,D%NUMP IM = D%MYMS(JM) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB1(JM,IGL) = D%NSTAGT1B(D%NPROCL(IGL)) + IPOS IPOS = IPOS+1 ELSE D%NPNTGTB1(JM,IGL) = -99 ENDIF ENDDO ENDDO ENDDO ! D%NSTAGT0B / D%NSTAGT1B: offset of peer rank in send/recv buffer ! D%NLTSGTB / D%NLTSFTB : size of peer rank in send/recv buffer ! D%NPNTGTB0 / D%NPNTGTB1: translation inp to global send buffer / recv to out buffer ENDIF ! GRIDPOINT SPACE ALLOCATE(D%NFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NFRSTLAT ',SIZE(D%NFRSTLAT ),SHAPE(D%NFRSTLAT ) ALLOCATE(D%NLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NLSTLAT ',SIZE(D%NLSTLAT ),SHAPE(D%NLSTLAT ) ALLOCATE(D%NPTRLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLAT ',SIZE(D%NPTRLAT ),SHAPE(D%NPTRLAT ) ALLOCATE(D%NPTRFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRFRSTLAT',SIZE(D%NPTRFRSTLAT),SHAPE(D%NPTRFRSTLAT) ALLOCATE(D%NPTRLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9)'D%NPTRLSTLAT',SIZE(D%NPTRLSTLAT),SHAPE(D%NPTRLSTLAT) ALLOCATE(D%LSPLITLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%LSPLITLAT',SIZE(D%LSPLITLAT),SHAPE(D%LSPLITLAT) ALLOCATE(D%NPROCA_GP(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCA_GP',SIZE(D%NPROCA_GP),SHAPE(D%NPROCA_GP) IF(.NOT.D%LWEIGHTED_DISTR) THEN ALLOCATE(ZDUM(1)) CALL SUMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT,LEQ_REGIONS,& &D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& &D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& &ZDUM,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& &IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN) ELSE CALL SUMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT,LEQ_REGIONS,& &D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& &D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& &D%RWEIGHT,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& &IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN) ENDIF D%NDGL_GP = D%NLSTLAT(MY_REGION_NS)-D%NFRSTLOFF IF (LLP1) THEN IF(.NOT.D%LGRIDONLY) THEN WRITE(NOUT,FMT='(/'' OUTPUT FROM ROUTINE SUMPLAT: ''/)') WRITE(NOUT,FMT='('' D%NULTPP '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NULTPP(1:NPRTRNS) WRITE(NOUT,FMT='('' D%NPROCL '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPROCL(1:R%NDGL) ENDIF WRITE(NOUT,FMT='('' D%NFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NFRSTLOFF D%NPTRFLOFF '')') WRITE(NOUT,FMT='(2(1X,I6))') D%NFRSTLOFF, D%NPTRFLOFF WRITE(NOUT,FMT='('' D%NPTRLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%LSPLITLAT '')') WRITE(NOUT,FMT='(50(1X,L1))') D%LSPLITLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%NPTRFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NPTRLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='(/)') ENDIF ALLOCATE(D%NSTA(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NSTA ',SIZE(D%NSTA ),SHAPE(D%NSTA ) ALLOCATE(D%NONL(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NONL ',SIZE(D%NONL ),SHAPE(D%NONL ) IF(.NOT.D%LWEIGHTED_DISTR) THEN CALL SUSTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,ZDUM,ZMEDIAP,D%NPROCA_GP) ELSE CALL SUSTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,D%RWEIGHT,ZMEDIAP,D%NPROCA_GP) ENDIF ! IGPTOTL is the number of grid points in each individual processor ALLOCATE(IGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IGPTOTL(:,:)=0 DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) IGPTOT = 0 DO JGL=D%NPTRFRSTLAT(JA),D%NPTRLSTLAT(JA) IGPTOT = IGPTOT+D%NONL(JGL,JB) ENDDO IGPTOTL(JA,JB) = IGPTOT ENDDO ENDDO D%NGPTOT = IGPTOTL(MY_REGION_NS,MY_REGION_EW) D%NGPTOTMX = MAXVAL(IGPTOTL) D%NGPTOTG = SUM(IGPTOTL) ALLOCATE(D%NGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NGPTOTL ',SIZE(D%NGPTOTL ),SHAPE(D%NGPTOTL ) D%NGPTOTL(:,:) = IGPTOTL(:,:) IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NSTAGTF(D%NDGL_FS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGTF ',SIZE(D%NSTAGTF ),SHAPE(D%NSTAGTF ) IOFF = 0 DO JGL=1,D%NDGL_FS D%NSTAGTF(JGL) = IOFF IGL = D%NPTRLS(MYSETW) + JGL - 1 ! Each latitude should be able to store NLON real values, or floor(NLON/2)+1 ! complex values. Note that IOFF should always be even, because we need to ! store complex values (i.e. 2 floats), but this is the case anyway. ! WARNING: Extra padding changes results, potentially, though it does not ! cause wrong results. IOFF = IOFF + (G%NLOEN(IGL)/2+1)*2 ENDDO D%NSTAGTF(D%NDGL_FS+1) = IOFF D%NLENGTF = IOFF ENDIF IF(ALLOCATED(ZDUM)) DEALLOCATE(ZDUM) DEALLOCATE(IGPTOTL) ALLOCATE(D%OFFSETS_GEMM1(D%NUMP+1)) ALLOCATE(D%OFFSETS_GEMM2(D%NUMP+1)) ALLOCATE(D%OFFSETS_GEMM_MATRIX(D%NUMP+1)) ALLOCATE(D%LEGENDRE_MATRIX_STRIDES(D%NUMP)) D%LEGENDRE_MATRIX_STRIDES = 0 OFFSET1 = 0 OFFSET2 = 0 OFFSET3 = 0 DO KMLOC=1,D%NUMP KM = D%MYMS(KMLOC) D%OFFSETS_GEMM1(KMLOC) = OFFSET1 D%OFFSETS_GEMM2(KMLOC) = OFFSET2 D%OFFSETS_GEMM_MATRIX(KMLOC) = OFFSET3 !KM=0 is transformed in double precision, no need to store here IF (KM /= 0) THEN OFFSET1 = OFFSET1 + ALIGN(G%NDGLU(KM),8) ! N_OFFSET takes the max of the two GEMMs OFFSET2 = OFFSET2 + ALIGN((R%NSMAX-KM+3)/2,8) D%LEGENDRE_MATRIX_STRIDES(KMLOC) = ALIGN(G%NDGLU(KM),8) ! Note that both sizes have to be aligned because we make the GEMMs ! multiples of 8 OFFSET3 = OFFSET3 + ALIGN((R%NSMAX-KM+3)/2,8) * D%LEGENDRE_MATRIX_STRIDES(KMLOC) ENDIF ENDDO D%OFFSETS_GEMM1(D%NUMP+1) = OFFSET1 D%OFFSETS_GEMM2(D%NUMP+1) = OFFSET2 D%OFFSETS_GEMM_MATRIX(D%NUMP+1) = OFFSET3 ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUMP_TRANS END MODULE SUMP_TRANS_MOD ectrans-1.8.0/src/trans/gpu/internal/ltdirad_mod.F900000775000175000017500000003327515174631767022470 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE LTDIRAD_MOD USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRB, JPRD, JPIB USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: PREPARE_LTDIRAD, LTDIRAD_HANDLE, LTDIRAD TYPE LTDIRAD_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HOUT_AND_POA TYPE(ALLOCATION_RESERVATION_HANDLE) :: HINPS_AND_ZINPA END TYPE CONTAINS FUNCTION PREPARE_LTDIRAD(ALLOCATOR, KF_FS, KF_UV) RESULT(HLTDIR) USE TPM_DISTR, ONLY: D USE TPM_DIM, ONLY: R USE ISO_C_BINDING, ONLY: C_SIZEOF USE LEDIR_MOD, ONLY: LEDIR_STRIDES USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV TYPE(LTDIRAD_HANDLE) :: HLTDIR INTEGER(KIND=JPIB) :: IALLOC_SZ INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE REAL(KIND=JPRBT) :: ZPRBT_DUMMY REAL(KIND=JPRD) :: ZPRD_DUMMY CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE,& IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) ! POA1 IALLOC_SZ = ALIGN(2_JPIB*KF_FS*(R%NTMAX+3)*D%NUMP*C_SIZEOF(ZPRBT_DUMMY),128) ! POA2 IALLOC_SZ = IALLOC_SZ + ALIGN(4_JPIB*KF_UV*(R%NTMAX+3)*D%NUMP*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUT IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUT0 IALLOC_SZ = IALLOC_SZ+ ALIGN(IOUT0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HLTDIR%HOUT_AND_POA = RESERVE(ALLOCATOR, IALLOC_SZ, "HLTDIRAD%HOUT_AND_POA") ! Check if the reuse buffer is large enough IALLOC_SZ = ALIGN(IIN_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) IALLOC_SZ = IALLOC_SZ + ALIGN(IIN_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) IALLOC_SZ = IALLOC_SZ + ALIGN(IIN0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) IALLOC_SZ = IALLOC_SZ + ALIGN(IIN0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HLTDIR%HINPS_AND_ZINPA = RESERVE(ALLOCATOR, IALLOC_SZ, "HLTDIRAD%HINPS_AND_ZINPA") END FUNCTION PREPARE_LTDIRAD SUBROUTINE LTDIRAD(ALLOCATOR,HLTDIR,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2, & & KFLDPTRUV,KFLDPTRSC) USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE TPM_GEOMETRY, ONLY: G USE LEDIR_MOD, ONLY: LEDIR_STRIDES USE LEINV_MOD, ONLY: LEINV USE UVTVDAD_MOD, ONLY: UVTVDAD USE UPDSPAD_MOD, ONLY: UPDSPAD USE UPDSPBAD_MOD, ONLY: UPDSPBAD USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_GEN, ONLY: LSYNC_TRANS USE TPM_TRANS, ONLY: NF_SC2, NF_SC3A, NF_SC3B USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_F_POINTER, C_LOC, C_SIZEOF !**** *LTDIR* - Control of Direct Legendre transform step ! Purpose. ! -------- ! Tranform from Fourier space to spectral space, compute ! vorticity and divergence. !** Interface. ! ---------- ! *CALL* *LTDIR(...)* ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! PRFI2 - prepares the Fourier work arrays for model variables. ! LEDIR - direct Legendre transform ! UVTVD - ! UPDSP - updating of spectral arrays (fields) ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-24 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified 94-04-06 R. El khatib Full-POS implementation ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group : 95-10-01 Support for Distributed Memory version ! K. YESSAD (AUGUST 1996): ! - Legendre transforms for transmission coefficients. ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! R. El Khatib 12-Jul-2012 LDSPC2 replaced by UVTVD ! ------------------------------------------------------------------ IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM) :: KM INTEGER(KIND=JPIM) :: KMLOC INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRBT) ,POINTER, INTENT(OUT) :: ZINPS(:), ZINPA(:) REAL(KIND=JPRD) ,POINTER, INTENT(OUT) :: ZINPS0(:), ZINPA0(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IFIRST REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JPRB), POINTER :: POA1_L(:), POA1(:,:,:) REAL(KIND=JPRB), POINTER :: POA2_L(:), POA2(:,:,:) REAL(KIND=JPRB), POINTER :: PU(:,:,:), PV(:,:,:), PVOR(:,:,:), PDIV(:,:,:) REAL(KIND=JPRBT), POINTER :: ZOUT(:) REAL(KIND=JPRD), POINTER :: ZOUT0(:) TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(LTDIRAD_HANDLE), INTENT(IN) :: HLTDIR INTEGER(KIND=JPIB) :: IALLOC_POS, IALLOC_SZ INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE INTEGER(KIND=JPIM) :: JFLD, JN ASSOCIATE(D_NUMP=>D%NUMP, R_NTMAX=>R%NTMAX) ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM ! -------------------------------------- ! ------------------------------------------------------------------ !* 2. PREPARE WORK ARRAYS. ! -------------------- CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE,& IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) IALLOC_POS = 1 IALLOC_SZ = ALIGN(2_JPIB*KF_FS*(R%NTMAX+3)*D%NUMP*C_SIZEOF(POA1_L(1)),128) CALL ASSIGN_PTR(POA1_L, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) CALL C_F_POINTER(C_LOC(POA1_L), POA1, (/ 2*KF_FS, R%NTMAX+3, D%NUMP /)) IALLOC_POS = IALLOC_POS + IALLOC_SZ IALLOC_SZ = ALIGN(4_JPIB*KF_UV*(R%NTMAX+3)*D%NUMP*C_SIZEOF(POA2_L(1)),128) CALL ASSIGN_PTR(POA2_L, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) CALL C_F_POINTER(C_LOC(POA2_L), POA2, (/ 4*KF_UV, R%NTMAX+3, D%NUMP /)) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUT IALLOC_SZ = ALIGN(IOUT_SIZE*C_SIZEOF(ZOUT(1)),128) CALL ASSIGN_PTR(ZOUT, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUT0 IALLOC_SZ = ALIGN(IOUT0_SIZE*C_SIZEOF(ZOUT0(1)),128) CALL ASSIGN_PTR(ZOUT0, GET_ALLOCATION(ALLOCATOR, HLTDIR%HOUT_AND_POA),& & IALLOC_POS, IALLOC_SZ, SET_STREAM=1) IALLOC_POS = IALLOC_POS + IALLOC_SZ IALLOC_POS=1 IALLOC_SZ = ALIGN(IIN_SIZE*C_SIZEOF(ZINPS(0)),128) CALL ASSIGN_PTR(ZINPS, GET_ALLOCATION(ALLOCATOR, HLTDIR%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ IALLOC_SZ = ALIGN(IIN_SIZE*C_SIZEOF(ZINPA(0)),128) CALL ASSIGN_PTR(ZINPA, GET_ALLOCATION(ALLOCATOR, HLTDIR%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ IALLOC_SZ = ALIGN(IIN0_SIZE*C_SIZEOF(ZINPS0(0)),128) CALL ASSIGN_PTR(ZINPS0, GET_ALLOCATION(ALLOCATOR, HLTDIR%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ IALLOC_SZ = ALIGN(IIN0_SIZE*C_SIZEOF(ZINPA0(0)),128) CALL ASSIGN_PTR(ZINPA0, GET_ALLOCATION(ALLOCATOR, HLTDIR%HINPS_AND_ZINPA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS=IALLOC_POS+IALLOC_SZ #ifdef ACCGPU !$ACC DATA PRESENT(POA1,R,R_NTMAX,D,D_NUMP) !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) COPYIN(KF_FS) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:POA1,R_NTMAX,D_NUMP) !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) SHARED(R,D,KF_FS,POA1) & !$OMP& MAP(TO:KF_FS) #endif DO KMLOC=1,D_NUMP DO JN=1,R_NTMAX+3 DO JFLD=1,2*KF_FS POA1(JFLD,JN,KMLOC) = 0 END DO END DO END DO #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif ! ------------------------------------------------------------------ !* 3. PREPARE FOURIER ARRAYS. ! ---------------------- ! ------------------------------------------------------------------ !* 4. COPY WORK ARRAYS TO DEVICE. ! --------------------------- #ifdef OMPGPU !$OMP TARGET DATA MAP(TO:PSPVOR,PSPDIV) IF(KF_UV > 0) !$OMP TARGET DATA MAP(TO:PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$OMP TARGET DATA MAP(TO:PSPSC2) IF(NF_SC2 > 0) !$OMP TARGET DATA MAP(TO:PSPSC3A) IF(NF_SC3A > 0) !$OMP TARGET DATA MAP(TO:PSPSC3B) IF(NF_SC3B > 0) #endif #ifdef ACCGPU !$ACC DATA COPYIN(PSPVOR,PSPDIV) IF(KF_UV > 0) !$ACC DATA COPYIN(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$ACC DATA COPYIN(PSPSC2) IF(NF_SC2 > 0) !$ACC DATA COPYIN(PSPSC3A) IF(NF_SC3A > 0) !$ACC DATA COPYIN(PSPSC3B) IF(NF_SC3B > 0) #endif ! ------------------------------------------------------------------ !* 6. UPDATE SPECTRAL ARRAYS. ! ----------------------- ! this is on the host, so need to cp from device, Nils CALL UPDSPAD(KF_UV,KF_SCALARS,POA1,& & PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ! ------------------------------------------------------------------ !* 5. COMPUTE VORTICITY AND DIVERGENCE. ! --------------------------------- IF( KF_UV > 0 ) THEN ! U and V are in POA1 IFIRST = 0 PU => POA1(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV PV => POA1(IFIRST+1:IFIRST+2*KF_UV,:,:) ! Compute VOR and DIV ino POA2 IFIRST = 0 PVOR => POA2(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV PDIV => POA2(IFIRST+1:IFIRST+2*KF_UV,:,:) ! Write back. Note, if we have UV, the contract says we *must* have VOR/DIV CALL UPDSPBAD(KF_UV,PVOR,PSPVOR,KFLDPTRUV) CALL UPDSPBAD(KF_UV,PDIV,PSPDIV,KFLDPTRUV) ! Compute vorticity and divergence CALL UVTVDAD(KF_UV,PU,PV,PVOR,PDIV) ENDIF #ifdef ACCGPU !$ACC WAIT(1) #endif IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(412,0) #ifdef OMPGPU !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif IF (LSYNC_TRANS) THEN CALL GSTATS(432,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(432,1) ENDIF CALL GSTATS(412,1) ! do the legendre transform CALL LEINV(ALLOCATOR,POA1,ZOUT,ZOUT0,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS) ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('LTDIRAD_MOD',1,ZHOOK_HANDLE) END ASSOCIATE END SUBROUTINE LTDIRAD END MODULE LTDIRAD_MOD ectrans-1.8.0/src/trans/gpu/internal/ltinvad_mod.F900000775000175000017500000003462715174631767022510 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE LTINVAD_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: LTINVAD, LTINVAD_HANDLE, PREPARE_LTINVAD TYPE LTINVAD_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPIA_AND_IN END TYPE CONTAINS FUNCTION PREPARE_LTINVAD(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) RESULT(HLTINVAD) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE TPM_DISTR, ONLY: D USE TPM_DIM, ONLY: R USE ISO_C_BINDING, ONLY: C_SIZEOF USE LEINV_MOD, ONLY: LEINV_STRIDES USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS LOGICAL, INTENT(IN) :: LVORGP,LDIVGP,LSCDERS TYPE(LTINVAD_HANDLE) :: HLTINVAD INTEGER(KIND=JPIB) :: IALLOC_SZ, IPIA_SZ INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE REAL(KIND=JPRBT) :: ZPRBT_DUMMY REAL(KIND=JPRD) :: ZPRD_DUMMY INTEGER(KIND=JPIM) :: IF_READIN, IF_LEG ! # fields that are initially read. We always read vorticity ! and divergence! Also keep in mind that we actually have 2X ! this number of levels because real+complex IF_READIN = 0 IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! U IF_READIN = IF_READIN + KF_UV ! V IF_READIN = IF_READIN + KF_SCALARS ! Scalars IF (LSCDERS) & IF_READIN = IF_READIN + KF_SCALARS ! Scalars NS Derivatives IPIA_SZ = ALIGN(2_JPIB*IF_READIN*(R%NSMAX+3)*D%NUMP*C_SIZEOF(ZPRBT_DUMMY),128) ! In Legendre space, we then ignore vorticity/divergence, if ! they don't need to be transformed. IF_LEG = IF_READIN IF(.NOT. LVORGP) IF_LEG = IF_LEG - KF_UV ! No vorticity needed IF(.NOT. LDIVGP) IF_LEG = IF_LEG - KF_UV ! No divergence needed CALL LEINV_STRIDES(IF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) ! PIA IALLOC_SZ = IPIA_SZ ! ZINP IALLOC_SZ = IALLOC_SZ + ALIGN(IIN_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZINP0 IALLOC_SZ = IALLOC_SZ + ALIGN(IIN0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HLTINVAD%HPIA_AND_IN = RESERVE(ALLOCATOR, IALLOC_SZ, "HLTINVAD_HPIA_AND_IN") END FUNCTION PREPARE_LTINVAD SUBROUTINE LTINVAD(ALLOCATOR,HLTINVAD,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & & ZOUTS,ZOUTA,ZOUTS0,ZOUTA0) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPRD, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_TRANS, ONLY: LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B, LSCDERS USE TPM_GEOMETRY, ONLY: G USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_DISTR, ONLY: D USE PRFI1BAD_MOD, ONLY: PRFI1BAD USE VDTUVAD_MOD, ONLY: VDTUVAD USE SPNSDEAD_MOD, ONLY: SPNSDEAD USE LEINV_MOD, ONLY: LEINV_STRIDES USE LEDIR_MOD, ONLY: LEDIR USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE TPM_FIELDS_GPU, ONLY: FG USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_GEN, ONLY: LSYNC_TRANS USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE ISO_C_BINDING, ONLY: C_LOC, C_SIZEOF, C_F_POINTER !**** *LTINVAD* - adjoint of inverse Legendre transform ! ! Purpose. ! -------- ! Adjoint of the "tranform from Laplace space to Fourier space, compute U and V ! and north/south derivatives of state variables". !** Interface. ! ---------- ! *CALL* *LTINVAD(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : The Laplace arrays of the model. ! -------------------- The values of the Legendre polynomials ! The grid point arrays of the model ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1B - prepares the spectral fields ! VDTUV - compute u and v from vorticity and divergence ! SPNSDE - compute north-south derivatives ! LEINV - Inverse Legendre transform ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINV in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRBT) , POINTER, INTENT(IN) :: ZOUTS(:), ZOUTA(:) REAL(KIND=JPRD) , POINTER, INTENT(IN) :: ZOUTS0(:), ZOUTA0(:) INTEGER(KIND=JPIM) :: IFIRST, J3 REAL(KIND=JPRB), POINTER :: PIA_L(:), PIA(:,:,:) REAL(KIND=JPRB), POINTER :: PU(:,:,:), PV(:,:,:), PVOR(:,:,:), PDIV(:,:,:) REAL(KIND=JPRB), POINTER :: PSCALARS(:,:,:), PSCALARS_NSDER(:,:,:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(LTINVAD_HANDLE), INTENT(IN) :: HLTINVAD INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE INTEGER(KIND=JPIM) :: JK, J, KMLOC, KM INTEGER(KIND=JPIM) :: IF_READIN, IF_LEG INTEGER(KIND=JPIB) :: IALLOC_POS, IALLOC_SZ REAL(KIND=JPRBT), POINTER :: ZINP(:) REAL(KIND=JPRD), POINTER :: ZINP0(:) REAL(KIND=JPRB), POINTER :: PIA_LEDIR(:,:,:) ASSOCIATE(ZEPSNM=>FG%ZEPSNM, D_NUMP=>D%NUMP, D_MYMS=>D%MYMS) ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('LTINVAD_MOD',0,ZHOOK_HANDLE) ! Get all pointers IF_READIN = 0 IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! U IF_READIN = IF_READIN + KF_UV ! V IF_READIN = IF_READIN + KF_SCALARS ! Scalars IF (LSCDERS) & IF_READIN = IF_READIN + KF_SCALARS ! Scalars NS Derivatives ! In Legendre space, we then ignore vorticity/divergence, if ! they don't need to be transformed. IF_LEG = IF_READIN IF(.NOT. LVORGP) IF_LEG = IF_LEG - KF_UV ! No vorticity needed IF(.NOT. LDIVGP) IF_LEG = IF_LEG - KF_UV ! No divergence needed CALL LEINV_STRIDES(IF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) IALLOC_POS = 1 ! PIA IALLOC_SZ = ALIGN(2_JPIB*IF_READIN*(R%NTMAX+3)*D%NUMP*C_SIZEOF(PIA_L(1)),128) CALL ASSIGN_PTR(PIA_L, GET_ALLOCATION(ALLOCATOR, HLTINVAD%HPIA_AND_IN),& & IALLOC_POS, IALLOC_SZ) CALL C_F_POINTER(C_LOC(PIA_L), PIA, (/ 2*IF_READIN, R%NTMAX+3, D%NUMP /)) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZINP IALLOC_SZ = ALIGN(IIN_SIZE*C_SIZEOF(ZINP(1)),128) CALL ASSIGN_PTR(ZINP, GET_ALLOCATION(ALLOCATOR, HLTINVAD%HPIA_AND_IN),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZINP0 IALLOC_SZ = ALIGN(IIN0_SIZE*C_SIZEOF(ZINP0(1)),128) CALL ASSIGN_PTR(ZINP0, GET_ALLOCATION(ALLOCATOR, HLTINVAD%HPIA_AND_IN),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! Assign pointers do the different components of PIA IFIRST = 0 IF (.NOT. LVORGP .OR. LDIVGP) THEN ! Usually we want to store vorticity first PVOR => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Vorticity PDIV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Divergence ELSE ! Except if we want to translate Vorticity but not Divergence, we should have Divergence first ! Then we have all buffers that move on in a contiguous buffer PDIV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Divergence PVOR => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! Vorticity ENDIF PU => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! U PV => PIA(IFIRST+1:IFIRST+2*KF_UV,:,:) IFIRST = IFIRST + 2*KF_UV ! V PSCALARS => PIA(IFIRST+1:IFIRST+2*KF_SCALARS,:,:) IFIRST = IFIRST + 2*KF_SCALARS ! Scalars IF (LSCDERS) THEN PSCALARS_NSDER => PIA(IFIRST+1:IFIRST+2*KF_SCALARS,:,:) IFIRST = IFIRST + 2*KF_SCALARS ! Scalars NS Derivatives ENDIF ! ------------------------------------------------------------------ !* 4. Adjoint of INVERSE LEGENDRE TRANSFORM. ! --------------------------- ! Legendre transforms. When converting PIA into ZOUT, we ignore the first entries of LEINV. ! This is because vorticity and divergence is not necessarily converted to GP space. PIA_LEDIR => PIA(2*(IF_READIN-IF_LEG)+1:IF_READIN,:,:) CALL LEDIR(ALLOCATOR,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,ZINP,ZINP0,PIA_LEDIR,IF_LEG) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) SHARED(D,PIA_LEDIR,IF_LEG) PRIVATE(KM) MAP(TO:IF_LEG) #endif #ifdef ACCGPU !$ACC DATA PRESENT(D,D_MYMS,D_NUMP,PIA_LEDIR) !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KMLOC,KM,J) & !$ACC& FIRSTPRIVATE(IF_LEG) DEFAULT(NONE) #endif DO KMLOC=1,D_NUMP DO JK=1,IF_LEG KM = D_MYMS(KMLOC) IF(KM == 0)THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,SIZE(PIA_LEDIR,2) PIA_LEDIR(2*JK,J,KMLOC) = 0.0_JPRB ENDDO ENDIF ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA #endif ! ------------------------------------------------------------------ !* 3. Adjoint of SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- #ifdef OMPGPU !$OMP TARGET DATA MAP(FROM:PSPVOR,PSPDIV) IF(KF_UV > 0) !$OMP TARGET DATA MAP(FROM:PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$OMP TARGET DATA MAP(FROM:PSPSC2) IF(NF_SC2 > 0) !$OMP TARGET DATA MAP(FROM:PSPSC3A) IF(NF_SC3A > 0) !$OMP TARGET DATA MAP(FROM:PSPSC3B) IF(NF_SC3B > 0) #endif #ifdef ACCGPU !$ACC DATA COPYOUT(PSPVOR,PSPDIV) IF(KF_UV > 0) !$ACC DATA COPYOUT(PSPSCALAR) IF(PRESENT(PSPSCALAR) .AND. KF_SCALARS > 0) !$ACC DATA COPYOUT(PSPSC2) IF(NF_SC2 > 0) !$ACC DATA COPYOUT(PSPSC3A) IF(NF_SC3A > 0) !$ACC DATA COPYOUT(PSPSC3B) IF(NF_SC3B > 0) #endif ! Compute NS derivatives if needed IF (LSCDERS) THEN CALL SPNSDEAD(KF_SCALARS,ZEPSNM,PSCALARS,PSCALARS_NSDER) ENDIF IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN CALL PRFI1BAD(PSCALARS,PSPSCALAR,KF_SCALARS,UBOUND(PSPSCALAR,2)) ELSE IFIRST = 1 IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN CALL PRFI1BAD(PSCALARS(IFIRST:IFIRST+2*NF_SC2-1,:,:),PSPSC2(:,:),NF_SC2,UBOUND(PSPSC2,2)) IFIRST = IFIRST+2*NF_SC2 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN DO J3=1,UBOUND(PSPSC3A,3) CALL PRFI1BAD(PSCALARS(IFIRST:IFIRST+2*NF_SC3A-1,:,:),PSPSC3A(:,:,J3),NF_SC3A,UBOUND(PSPSC3A,2)) IFIRST = IFIRST+2*NF_SC3A ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN DO J3=1,UBOUND(PSPSC3B,3) CALL PRFI1BAD(PSCALARS(IFIRST:IFIRST+2*NF_SC3B-1,:,:),PSPSC3B(:,:,J3),NF_SC3B,UBOUND(PSPSC3B,2)) IFIRST = IFIRST+2*NF_SC3B ENDDO ENDIF IF(IFIRST-1 /= 2*KF_SCALARS) THEN WRITE(0,*) 'LTINV:KF_SCALARS,IFIRST',KF_SCALARS,IFIRST CALL ABORT_TRANS('LTINV_MOD:IFIRST /= 2*KF_SCALARS') ENDIF ENDIF ENDIF IF (KF_UV > 0) THEN ! Compute U and V for VOR and DIV CALL VDTUVAD(KF_UV,ZEPSNM,PVOR,PDIV,PU,PV) CALL PRFI1BAD(PVOR,PSPVOR,KF_UV,UBOUND(PSPVOR,2)) CALL PRFI1BAD(PDIV,PSPDIV,KF_UV,UBOUND(PSPDIV,2)) ENDIF IF (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(422,0) #ifdef OMPGPU !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif IF (LSYNC_TRANS) THEN CALL GSTATS(442,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(442,1) ENDIF CALL GSTATS(422,1) IF (LHOOK) CALL DR_HOOK('LTINVAD_MOD',1,ZHOOK_HANDLE) END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE LTINVAD END MODULE LTINVAD_MOD ectrans-1.8.0/src/trans/gpu/internal/suleg_mod.F900000775000175000017500000006122615174631767022161 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE SULEG_MOD CONTAINS SUBROUTINE SULEG !DEC$ OPTIMIZE:1 USE PARKIND_ECTRANS, ONLY: JPRD, JPIM USE PARKIND2, ONLY: JPRH USE MPL_MODULE, ONLY: MPL_BARRIER, JP_NON_BLOCKING_STANDARD, MPL_RECV, MPL_SEND, & & MPL_WAIT USE TPM_GEN, ONLY: NOUT, LMPOFF, NPRINTLEV USE TPM_DIM, ONLY: R USE TPM_CONSTANTS, ONLY: RA USE TPM_DISTR, ONLY: NPRTRV, NPRTRW, NPROC, D, MTAGLETR, MYSETV, MYSETW, NPRCIDS USE TPM_FIELDS, ONLY: F USE TPM_FLT, ONLY: S USE TPM_GEOMETRY, ONLY: G USE TPM_CTL, ONLY: C USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE PRE_SULEG_MOD, ONLY: PRE_SULEG USE SUGAW_MOD, ONLY: SUGAW USE SUPOL_MOD, ONLY: SUPOL USE SUPOLF_MOD, ONLY: SUPOLF USE TPM_POL, ONLY: INI_POL, END_POL USE SUTRLE_MOD, ONLY: SUTRLE USE SETUP_GEOM_MOD, ONLY: SETUP_GEOM USE SEEFMM_MIX, ONLY: SETUP_SEEFMM USE SET2PE_MOD, ONLY: SET2PE USE PREPSNM_MOD, ONLY: PREPSNM USE WRITE_LEGPOL_MOD, ONLY: WRITE_LEGPOL USE READ_LEGPOL_MOD, ONLY: READ_LEGPOL !**** *SULEG * - initialize the Legendre polynomials ! Purpose. ! -------- ! Initialize COMMON YOMLEG !** Interface. ! ---------- ! *CALL* *SULEG* ! Explicit arguments : ! -------------------- ! Implicit arguments : ! -------------------- ! COMMON YOMLEG ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! SUGAW (Gaussian latitudes) ! SUPOLM (polynomials) ! LFI routines for external IO's ! Called by SUGEM. ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! ! S.L. Belousov, Tables of normalized associated Legendre Polynomials, Pergamon Press (1962) ! P.N. Swarztrauber, On computing the points and weights for Gauss-Legendre quadrature, ! SIAM J. Sci. Comput. Vol. 24 (3) pp. 945-954 (2002) ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-10-15 ! MODIFICATION : 91-04 J.M. Piriou: ! - Read gaussian latitudes and PNM on LFI ! - If file missing, computes ! 91-04 M.Hamrud: ! - IO Scheme introduced ! MODIFICATION : 91-07-03 P.Courtier suppress derivatives ! MODIFICATION : 91-07-03 P.Courtier computes RATATH and RACTHE ! MODIFICATION : 91-07-03 P.Courtier change upper limit (NSMAX+1) ! MODIFICATION : 91-07-03 P.Courtier change ordering ! Order of the PNM in the file, as in the model : ! - increasing wave numbers m ! - for a given m, from n=NSMAX+1 to m ! MODIFICATION : 92-07-02 R. Bubnova: shift RATATH calculation ! to SUGEM1 ! MODIFICATION : 92-12-17 P.Courtier multitask computations ! Modified by R. EL Khatib : 93-04-02 Set-up defaults controled by LECMWF ! MODIFICATION : 93-03-19 D.Giard : n <= NTMAX ! K. YESSAD : 93-05-11 : DLMU --> global array DRMU(NDGSA:NDGEN). ! (not stored currently on LFI files). ! MODIFICATION : 94-02-03 R. El Khatib : subroutine SULEG2 to write out ! the Leg. polynomials on workfile or LFI file ! Modification : 94-08-31 M. Tolstykh: Setup for CUD interpolation ! Modified by K. YESSAD (MARCH 1995): Extra-latitudes computations ! according to value of NDGSUR and LRPOLE only. ! + change fancy loop numbering. ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option. ! - removal of LRPOLE in YOMCT0. ! - removal of code under LRPOLE. ! R. El Khatib 11-Apr-2007 Emulation of vectorized quadruple precision ! on NEC ! Nils Wedi + Mats Hamrud, 2009-02-05 revised following Swarztrauber, 2002 ! G.Mozdzynski: March 2011 Support 2D (RW,RV) initialisation of legendre coeffs ! G.Mozdzynski: July 2012 distribute FLT initialisation over NPRTRV ! R. El Khatib 14-Jun-2013 optional computation on the stretched latitudes ! F. Vana 05-Mar-2015 Support for single precision ! Nils Wedi, 20-Apr-2015 Support dual latitude/longitude set ! T. Wilhelmsson, 22-Sep-2016 Support single precision for dual too ! ------------------------------------------------------------------ IMPLICIT NONE ! LOCAL ! ------------------------------------------------------------------ REAL(KIND=JPRD),ALLOCATABLE :: ZPNMG(:) REAL(KIND=JPRD),ALLOCATABLE :: ZFN(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZLRMUZ2(:) REAL(KIND=JPRD) :: ZLRMUZ(R%NDGL) REAL(KIND=JPRD) :: ZW(R%NDGL) REAL(KIND=JPRD) :: ZANM REAL(KIND=JPRD) :: ZFNN REAL(KIND=JPRD) :: ZPI, ZINC, ZOFF, ZTEMP, ZORIG, ZTHETA, ZCOS REAL(KIND=JPRD), ALLOCATABLE :: ZSNDBUFV(:),ZRCVBUFV(:,:) INTEGER(KIND=JPIM) :: ISENDREQ(NPRTRV) INTEGER(KIND=JPIM) :: IRECVREQ(NPRTRV) INTEGER(KIND=JPIM) :: INM, IM, IRECV, ISEND, ISREQ, IRREQ, & &JGL, JM, JMLOC, IMLOC, JN, JNM, IODD, INN, INMAX, JI, IMAXN, ITAG, & &INX, ISL, ISTART, ITHRESHOLD, INSMAX, IMAXCOLS,ILATSMAX,JW,JV,J, & &IDGLU, ILA, ILS, IA, IS, I, ILATS, ILOOP, IPRTRV, JSETV, JH, & &IMAXRECVA, IMAXRECVS, IHEMIS, INNH, IGL, IGL1, IGL2, & &IDGLU2, ISYM, INZ REAL(KIND=JPRD) :: ZEPS_INT_DEC REAL(KIND=JPRD) :: ZEPS REAL(KIND=JPRD),ALLOCATABLE :: ZLFPOL(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZLPOL(:) LOGICAL :: LLP1,LLP2 ! For latitudes on the stretched geometry REAL(KIND=JPRH) :: ZTAN REAL(KIND=JPRH) :: ZSTRETMU(R%NDGL) ! ------------------------------------------------------------------ !* 0. Some initializations. ! --------------------- ZEPS = 1000._JPRD*EPSILON(ZEPS) !ZEPS_INT_DEC = EPSILON(ZEPS) ZEPS_INT_DEC = 1.0E-7_JPRD !ZEPS_INT_DEC = 1.0E-5_JPRD IHEMIS=1 IF (S%LSOUTHPNM) IHEMIS=2 LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SULEG ===' IF( NPROC > 1 )THEN CALL GSTATS(798,0) CALL MPL_BARRIER(CDSTRING='SULEG:') CALL GSTATS(798,1) ENDIF CALL GSTATS(140,0) CALL GSTATS(1801,0) IF(.NOT.D%LGRIDONLY) THEN CALL PRE_SULEG ENDIF ALLOCATE(F%RMU(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%RMU ',SIZE(F%RMU ),SHAPE(F%RMU ) ALLOCATE(F%RW(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%RW ',SIZE(F%RW ),SHAPE(F%RW ) !* 1.0 Initialize Fourier coefficients for ordinary Legendre polynomials ! ------------------------------------------------------------------------ ALLOCATE(ZFN(0:R%NDGL,0:R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'ZFN ',SIZE(ZFN ),SHAPE(ZFN ) ! determines the number of stripes in butterfly NSMAX/IMAXCOLS ! IMAXCOLS = (R%NSMAX - 1)/4 + 1 ! IMAXCOLS=64 (min flops) IMAXCOLS=64 ! the threshold of efficiency IF(NPROC == 1 .OR. R%NDGNH <= 2560) THEN ITHRESHOLD = R%NDGNH/4 DO IF(ITHRESHOLD >= IMAXCOLS*4) EXIT IMAXCOLS = IMAXCOLS/2 ENDDO ELSE ITHRESHOLD = 900 ENDIF ITHRESHOLD = MAX(ITHRESHOLD,IMAXCOLS+1) S%ITHRESHOLD = ITHRESHOLD !* 3.1 Gaussian latitudes and weights ! --------------------------------------- CALL INI_POL(R%NTMAX+3) IF(.NOT.D%LGRIDONLY) THEN ISTART=1 ELSE ISTART=R%NDGL ENDIF INMAX=R%NDGL ! Belousov, Swarztrauber use ZFN(0,0)=SQRT(2._JPRD) ! IFS normalisation chosen to be 0.5*Integral(Pnm**2) = 1 ZFN(0,0)=2._JPRD DO JN=ISTART,R%NDGL ZFNN=ZFN(0,0) DO JGL=1,JN ZFNN=ZFNN*SQRT(1._JPRD-0.25_JPRD/REAL(JGL**2,JPRD)) ENDDO IODD=MOD(JN,2) ZFN(JN,JN)=ZFNN DO JGL=2,JN-IODD,2 ZFN(JN,JN-JGL)=ZFN(JN,JN-JGL+2)*REAL((JGL-1)*(2*JN-JGL+2),JPRD)/REAL(JGL*(2*JN-JGL+1),JPRD) ENDDO ENDDO ! compute latitudes and weights for original Gaussian latitudes ZANM=SQRT(REAL(2*INMAX+1,JPRD)*REAL(INMAX**2,JPRD)/REAL(2*INMAX-1,JPRD)) INN=R%NDGL CALL GSTATS(1801,2) CALL SUGAW(INN,0,INMAX,ZLRMUZ(1:INN),ZW(1:INN),ZANM,ZFN) CALL GSTATS(1801,3) IF (ABS(G%RSTRET-1.0_JPRD)>100._JPRD*EPSILON(1._JPRD)) THEN WRITE(NOUT,*) '=== SULEG: Change Gaussian latitudes to the transformed sphere ===' INNH=(INN+1)/2 ZTAN=(1.0_JPRD-G%RSTRET**2)/(1.0_JPRD+G%RSTRET**2) ! North hemisphere DO JGL=1,INNH ZSTRETMU(JGL)=(ZTAN+REAL(ZLRMUZ(JGL),JPRH))/(1.0_JPRD+ZTAN*REAL(ZLRMUZ(JGL),JPRH)) ENDDO ! South hemisphere DO JGL=1,INNH IGL=2*INNH-JGL+1 ZSTRETMU(IGL)=(ZTAN-REAL(ZLRMUZ(JGL),JPRH))/(1.0_JPRD-ZTAN*REAL(ZLRMUZ(JGL),JPRH)) ENDDO DO JGL=1,INN ZLRMUZ(JGL)=REAL(ZSTRETMU(JGL),JPRD) ENDDO ENDIF DO JGL=1,R%NDGL F%RW(JGL) = ZW(JGL) F%RMU(JGL) = ZLRMUZ(JGL) ENDDO IF (LLP1) WRITE(NOUT,*) '=== SULEG: Finished Gaussian latitudes ===' !* 3.1.1 specify a dual set of output (inv_trans) or input (dir_trans) latitudes / longitudes IF( S%LDLL ) THEN INMAX = S%NDGL INN= S%NDGL S%NDGNHD = (INMAX+1)/2 ALLOCATE(ZLRMUZ2(INN)) ! here we want to use the positions of the specified dual grid ! accuracy requirement is ZLRMUZ2(JGL) < F%RMU(1) ! so we use approximations for the remaining latitudes outside this range ! we approximate the vicinity to the pole/equator ZPI = 2.0_JPRD*ASIN(1.0_JPRD) ZORIG = ASIN(F%RMU(1)) IF( S%LSHIFTLL ) THEN ZINC = ZPI/REAL(INN,JPRD) ZOFF = 0.5_JPRD*ZINC ZTEMP = ZOFF + ZINC*REAL(S%NDGNHD-1,JPRD) ZLRMUZ2(1) = SIN(MIN(ZTEMP,ZORIG) - 0.5_JPRD*MAX(0._JPRD,ZTEMP - ZORIG)) ZLRMUZ2(S%NDGNHD) = SIN(ZOFF) ELSE ZINC = ZPI/REAL(INN-2,JPRD) ZOFF=-0.5_JPRD*ZINC ZTEMP = ZOFF + ZINC*REAL(S%NDGNHD-1,JPRD) ZLRMUZ2(1) = SIN(MIN(ZTEMP,ZORIG) - 0.5_JPRD*MAX(0._JPRD,ZTEMP - ZORIG)) ZOFF=0.01_JPRD*ZINC ZLRMUZ2(S%NDGNHD) = SIN(ZOFF) ZOFF=0._JPRD ENDIF DO JGL=2, S%NDGNHD-1 ZLRMUZ2(JGL) = SIN(ZOFF + ZINC*REAL(S%NDGNHD-JGL,JPRD)) ENDDO DO JGL=1, S%NDGNHD ISYM = INN-JGL+1 ZLRMUZ2(ISYM) = -ZLRMUZ2(JGL) ENDDO IF( LLP2 ) THEN WRITE(NOUT,*) 'dual latitudes' DO JGL= 1, INN WRITE(NOUT,*) 'dual JGL=',JGL,(180._JPRD/ZPI)*ZINC,(180._JPRD/ZPI)*ASIN(ZLRMUZ2(JGL)),& & (180._JPRD/ZPI)*ASIN(F%RMU(JGL)) ENDDO ENDIF ALLOCATE(F%RMU2(INMAX)) IF (LLP2) WRITE(NOUT,9) 'F%RMU2 ',SIZE(F%RMU2 ),SHAPE(F%RMU2 ) ALLOCATE(F%RACTHE2(INMAX)) IF (LLP2) WRITE(NOUT,9) 'F%RACTHE2 ',SIZE(F%RACTHE2),SHAPE(F%RACTHE2 ) DO JGL=1,INN F%RMU2(JGL) = ZLRMUZ2(JGL) F%RACTHE2(JGL) = 1.0_JPRD/(SQRT(1.0_JPRD-ZLRMUZ2(JGL)*ZLRMUZ2(JGL))+ZEPS)/REAL(RA,JPRD) ENDDO IF (LLP1) WRITE(NOUT,*) '=== SULEG: Finished dual Gaussian latitudes ===' ! inverse + direct map for FMM INX=2*R%NDGNH INZ=2*S%NDGNHD ALLOCATE(S%FMM_INTI) CALL SETUP_SEEFMM(INX,F%RMU,INZ,F%RMU2,S%FMM_INTI) ENDIF !* 3.2 Computes related arrays IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(S%FA(D%NUMP)) ALLOCATE(F%R1MU2(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%R1MU2 ',SIZE(F%R1MU2),SHAPE(F%R1MU2 ) ALLOCATE(F%RACTHE(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%RACTHE ',SIZE(F%RACTHE),SHAPE(F%RACTHE ) IF( S%LUSE_BELUSOV) THEN ALLOCATE(F%RPNM(R%NLEI3,D%NSPOLEGL)) IF (LLP2) WRITE(NOUT,9) 'F%RPNM ',SIZE(F%RPNM),SHAPE(F%RPNM) DO JNM=1,D%NSPOLEGL F%RPNM(R%NLEI3,JNM) = 0.0_JPRD ENDDO ENDIF !* 3.2 Computes related arrays DO JGL=1,R%NDGL ! test cosine differently ZTHETA = ASIN(ZLRMUZ(JGL)) ZCOS = COS(ZTHETA) F%R1MU2(JGL) = ZCOS**2 F%RACTHE(JGL) = 1.0_JPRD/ZCOS/REAL(RA,JPRD) ENDDO !* 3.3 Working arrays ! compute the Legendre polynomials as a function of the z_k (Gaussian Latitudes) ! this may be faster than calling supolf for each m but uses extra communication ! and the parallelism is more limited ? Nils IF( S%LUSE_BELUSOV .AND. .NOT. C%LREAD_LEGPOL ) THEN INSMAX = R%NTMAX+1 IF( INSMAX /= R%NDGL) THEN DEALLOCATE(ZFN) ALLOCATE(ZFN(0:INSMAX,0:INSMAX)) ! Belousov, Swarztrauber use ZFN(0,0)=SQRT(2._JPRD) ! IFS normalisation chosen to be 0.5*Integral(Pnm**2) = 1 ZFN(0,0)=2._JPRD DO JN=1,INSMAX ZFNN=ZFN(0,0) DO JGL=1,JN ZFNN=ZFNN*SQRT(1._JPRD-0.25_JPRD/REAL(JGL**2,JPRD)) ENDDO IODD=MOD(JN,2) ZFN(JN,JN)=ZFNN DO JGL=2,JN-IODD,2 ZFN(JN,JN-JGL)=ZFN(JN,JN-JGL+2)*REAL((JGL-1)*(2*JN-JGL+2),JPRD)/REAL(JGL*(2*JN-JGL+1),JPRD) ENDDO ENDDO ENDIF ALLOCATE(ZLFPOL(0:INSMAX,0:INSMAX)) ALLOCATE(ZPNMG(R%NSPOLEG)) DO JH=1,IHEMIS IF (JH==1) THEN IGL1=D%NLATLS(MYSETW,MYSETV) IGL2=D%NLATLE(MYSETW,MYSETV) ELSE IGL1=R%NDGL-D%NLATLE(MYSETW,MYSETV)+1 IGL2=R%NDGL-D%NLATLS(MYSETW,MYSETV)+1 ENDIF ILOOP=0 DO JGL=IGL1,IGL2 INM = 0 CALL SUPOL(INSMAX,ZLRMUZ(JGL),ZFN,ZLFPOL) DO JM=0,R%NSMAX DO JN=INSMAX,JM,-1 INM = INM+1 ZPNMG(INM) = ZLFPOL(JM,JN) ENDDO ENDDO CALL GSTATS(1801,2) ILOOP = JGL-IGL1+1 CALL SUTRLE(ZPNMG,JGL,ILOOP) CALL GSTATS(1801,3) ENDDO ILATSMAX=0 DO JW=1,NPRTRW DO JV=1,NPRTRV ILATSMAX=MAX(ILATSMAX,D%NLATLE(JW,JV)-D%NLATLS(JW,JV)+1) ENDDO ENDDO ILATS=IGL2-IGL1+1 IF (S%LSOUTHPNM .AND. IHEMIS==1 .AND. ILATSMAX-1 >= ILATS) THEN ! I don't know what to do for south pole. But isn't this piece of code ! a dead stuff for poles rows ? CALL ABORT_TRANS('SULEG: WILL BE BROKEN FOR SOUTH HEMISPHERE') ENDIF DO J=ILATS,ILATSMAX-1 ILOOP=ILOOP+1 CALL GSTATS(1801,2) CALL SUTRLE(ZPNMG,-1,ILOOP) CALL GSTATS(1801,3) ENDDO ENDDO DEALLOCATE(ZLFPOL) IF( ALLOCATED(ZFN) ) DEALLOCATE(ZFN) DEALLOCATE(ZPNMG) IF(LLP1) WRITE(NOUT,*) '=== SULEG: Finished RPNM ===' ENDIF CALL SETUP_GEOM IMAXN=R%NTMAX+1 ITAG=MTAGLETR IMAXRECVA=0 IMAXRECVS=0 DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IMAXRECVA = MAX(IDGLU*ILA,IMAXRECVA) IMAXRECVS = MAX(IDGLU*ILS,IMAXRECVS) !find nearest starting latitude of the dual set IF( S%LDLL ) THEN INMAX=MIN(R%NTMAX+1,S%NDGL) IDGLU2=S%NDGNHD S%FA(JMLOC)%ISLD = 1 LLA:DO JGL=1,S%NDGNHD-1 IF( (ZLRMUZ2(JGL) < ZLRMUZ(ISL)) ) THEN S%FA(JMLOC)%ISLD = JGL IDGLU2 = S%NDGNHD-S%FA(JMLOC)%ISLD+1 EXIT LLA ENDIF ENDDO LLA IF( .NOT. C%LREAD_LEGPOL ) THEN CALL ABORT_TRANS('SULEG: Code path not (yet) supported in GPU version') ENDIF ! LREAD_LEGPOL ENDIF ! LDLL ENDDO IF( S%LDLL ) THEN DEALLOCATE(ZLRMUZ2) ENDIF CALL GSTATS(1801,2) IF(.NOT.C%LREAD_LEGPOL) THEN ! Loop over all zonal wavenumbers I'm responsible for, in strides of NPRTRV ! Every member of the same W set needs exactly the same polynomials ! Rather than have one member from each W set compute all the polynomials and then communicate ! them to the others, each member in the W set is recruited to calculate exactly one polynomial ! E.g. MYSETV=1 computes the first, MYSETV=2 the second, and so on ! This way the cost of precomputing the polynomials is shared among all members of the W set ! Each member then communicates its polynomial to the other members, so they all have a ! complete set DO JMLOC = 1, D%NUMP, NPRTRV IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) ! --------------------anti-symmetric----------------------- ! Allocate antisymmetric polynomials for this batch of NPRTRV zonal wavenumbers DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(S%FA(IMLOC)%RPNMA(IDGLU,ILA)) ENDDO IF( .NOT. S%LUSE_BELUSOV ) THEN ISREQ = 0 IRREQ = 0 ! Post receives for all polynomials in this NPRTRV batch ALLOCATE (ZRCVBUFV(IMAXRECVA,IPRTRV)) CALL GSTATS(851,0) DO JSETV=1,IPRTRV CALL SET2PE(IRECV,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN IRREQ = IRREQ+1 CALL MPL_RECV(ZRCVBUFV(:,JSETV),KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) IF( JMLOC+MYSETV-1 <= D%NUMP )THEN ! Determine properties of the polynomial I'm responsible for IMLOC=JMLOC+MYSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(ZSNDBUFV(IDGLU*ILA)) IF(MOD(IMAXN-IM,2) == 0) THEN INMAX=IMAXN+1 ELSE INMAX=IMAXN ENDIF ! Calculate my polynomial with SUPOLF CALL GSTATS(1251,0) IF (.NOT.ALLOCATED(ZLPOL)) ALLOCATE(ZLPOL(0:INMAX)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,ZLPOL,JI,JN) DO JGL=1,IDGLU CALL SUPOLF(IM,INMAX,ZLRMUZ(ISL+JGL-1),ZLPOL(0:INMAX),KCHEAP=3) DO JI=1,ILA JN=IM+2*(JI-1)+1 ZSNDBUFV((JGL-1)*ILA+JI)=ZLPOL(JN) ENDDO ENDDO !$OMP END PARALLEL DO IF (ALLOCATED(ZLPOL)) DEALLOCATE(ZLPOL) CALL GSTATS(1251,1) ! Post sends to the other members of my W set CALL GSTATS(851,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZSNDBUFV(:),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) ENDIF CALL GSTATS(851,0) IF(IRREQ > 0) THEN CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF(ISREQ > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF( NPROC==1.AND.LMPOFF )THEN ZRCVBUFV(1:SIZE(ZSNDBUFV(:)),1)=ZSNDBUFV(:) ENDIF CALL GSTATS(851,1) ! Now unpack the polynomials I've received into their respective storage work arrays CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IA,ILA,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) DO JGL=1,IDGLU DO JI=1,ILA S%FA(IMLOC)%RPNMA(JGL,ILA-JI+1)=ZRCVBUFV((JGL-1)*ILA+JI,JSETV) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1251,1) IF( ALLOCATED(ZSNDBUFV) ) DEALLOCATE(ZSNDBUFV) IF( ALLOCATED(ZRCVBUFV) ) DEALLOCATE(ZRCVBUFV) ELSE ! Take the values from the arrays computed earlier with the Belusov algorithm CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IA,ILA,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) DO JI=1,ILA DO JGL=1,IDGLU S%FA(IMLOC)%RPNMA(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IA+(JI-1)*2) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1251,1) ENDIF ! --------------------symmetric----------------------- ! Allocate symmetric polynomials for this batch of NPRTRV zonal wavenumbers DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(S%FA(IMLOC)%RPNMS(IDGLU,ILS)) ENDDO IF( .NOT. S%LUSE_BELUSOV ) THEN ISREQ = 0 IRREQ = 0 ! Post receives for all polynomials in this NPRTRV batch ALLOCATE (ZRCVBUFV(IMAXRECVS,IPRTRV)) CALL GSTATS(851,0) DO JSETV=1,IPRTRV CALL SET2PE(IRECV,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN IRREQ = IRREQ+1 CALL MPL_RECV(ZRCVBUFV(:,JSETV),KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) IF( JMLOC+MYSETV-1 <= D%NUMP )THEN ! Determine properties of the polynomial I'm responsible for IMLOC=JMLOC+MYSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(ZSNDBUFV(IDGLU*ILS)) IF(MOD(IMAXN-IM,2) == 0) THEN INMAX=IMAXN ELSE INMAX=IMAXN+1 ENDIF ! Calculate my polynomial with SUPOLF CALL GSTATS(1251,0) IF (.NOT.ALLOCATED(ZLPOL)) ALLOCATE(ZLPOL(0:INMAX)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,ZLPOL,JI,JN) DO JGL=1,IDGLU CALL SUPOLF(IM,INMAX,ZLRMUZ(ISL+JGL-1),ZLPOL(0:INMAX),KCHEAP=2) DO JI=1,ILS JN=IM+2*(JI-1) ZSNDBUFV((JGL-1)*ILS+JI)=ZLPOL(JN) ENDDO ENDDO !$OMP END PARALLEL DO IF (ALLOCATED(ZLPOL)) DEALLOCATE(ZLPOL) CALL GSTATS(1251,1) ! Post sends to the other members of my W set CALL GSTATS(851,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZSNDBUFV(:),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) ENDIF CALL GSTATS(851,0) IF(IRREQ > 0) THEN CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF(ISREQ > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF( NPROC==1.AND.LMPOFF )THEN ZRCVBUFV(1:SIZE(ZSNDBUFV(:)),1)=ZSNDBUFV(:) ENDIF CALL GSTATS(851,1) ! Now unpack the polynomials I've received into their respective storage work arrays CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IS,ILS,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) DO JGL=1,IDGLU DO JI=1,ILS S%FA(IMLOC)%RPNMS(JGL,ILS-JI+1)=ZRCVBUFV((JGL-1)*ILS+JI,JSETV) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1251,1) IF( ALLOCATED(ZSNDBUFV) ) DEALLOCATE(ZSNDBUFV) IF( ALLOCATED(ZRCVBUFV) ) DEALLOCATE(ZRCVBUFV) ELSE ! Take the values from the arrays computed earlier with the Belusov algorithm CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IS,ILS,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) DO JI=1,ILS DO JGL=1,IDGLU S%FA(IMLOC)%RPNMS(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IS+(JI-1)*2) ENDDO ENDDO END DO !$OMP END PARALLEL DO CALL GSTATS(1251,1) ENDIF ENDDO ! End of loop over zonal wavenumbers ENDIF CALL GSTATS(1801,3) IF(S%LUSE_BELUSOV) DEALLOCATE(F%RPNM) IF(C%LWRITE_LEGPOL) CALL WRITE_LEGPOL IF(C%LREAD_LEGPOL) CALL READ_LEGPOL ENDIF CALL GSTATS(1801,1) CALL GSTATS(140,1) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) CALL END_POL END SUBROUTINE SULEG END MODULE SULEG_MOD ectrans-1.8.0/src/trans/gpu/internal/spnorm_ctl_mod.F900000775000175000017500000000336415174631767023221 0ustar alastairalastair! (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. ! MODULE SPNORM_CTL_MOD CONTAINS SUBROUTINE SPNORM_CTL(PNORM,PSPEC,KFLD,KFLD_G,KVSET,KMASTER,PMET) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D, MYPROC, MYSETV USE SPNORMD_MOD, ONLY: SPNORMD USE SPNORMC_MOD, ONLY: SPNORMC ! IMPLICIT NONE REAL(KIND=JPRB) , INTENT(OUT) :: PNORM(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFLD,KFLD_G INTEGER(KIND=JPIM) :: IVSET(KFLD_G) REAL(KIND=JPRBT) :: ZMET(0:R%NSMAX) REAL(KIND=JPRBT) :: ZSM(KFLD,D%NUMP) REAL(KIND=JPRBT) :: ZGM(KFLD_G,0:R%NSMAX) ! ------------------------------------------------------------------ IF(PRESENT(KVSET)) THEN IVSET(:) = KVSET(:) ELSE IVSET(:) = MYSETV ENDIF IF(PRESENT(PMET)) THEN ZMET(:) = PMET(:) ELSE ZMET(:) = 1.0_JPRBT ENDIF CALL SPNORMD(PSPEC,KFLD,ZMET,ZSM) CALL SPNORMC(ZSM,KFLD_G,IVSET,KMASTER,R%NSMAX,ZGM) IF(MYPROC == KMASTER) THEN PNORM(1:KFLD_G) = REAL(SUM(ZGM,DIM=2), KIND=JPRB) PNORM(1:KFLD_G) = SQRT(PNORM(1:KFLD_G)) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SPNORM_CTL END MODULE SPNORM_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/prfi1bad_mod.F900000775000175000017500000000762515174631767022535 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE PRFI1BAD_MOD CONTAINS SUBROUTINE PRFI1BAD(PIA,PSPEC,KFIELDS,KDIM,KFLDPTR) USE PARKIND1, ONLY: JPIM, JPRB USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1B(...)* ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPEC - spectral array ! KFIELDS - number of fields ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1B in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM) :: KM,KMLOC REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PIA(:,:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KDIM INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: INM, IR, JN, JFLD, IASM0 ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- ASSOCIATE(D_NUMP=>D%NUMP, D_MYMS=>D%MYMS, D_NASM0=>D%NASM0, R_NSMAX=>R%NSMAX) #ifdef ACCGPU !$ACC DATA PRESENT(D,D_NUMP,R,R_NSMAX,D_MYMS,D_NASM0,PIA,PSPEC) ASYNC(1) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:D,D_NUMP,R,R_NSMAX,D_MYMS,D_NASM0,PIA,PSPEC) #endif IF(PRESENT(KFLDPTR)) THEN CALL ABORT_TRANS("KFLDPTR not implemented for GPU") ELSE !loop over wavenumber #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(KM,IASM0,INM) SHARED(KFIELDS,D,R,PIA,PSPEC) MAP(TO:KFIELDS) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,IASM0,INM) FIRSTPRIVATE(KFIELDS) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=0,R_NSMAX+3 DO JFLD=1,KFIELDS KM = D_MYMS(KMLOC) IF (JN > 1 .AND. JN <= R_NSMAX+2-KM) THEN IASM0 = D_NASM0(KM) INM = IASM0+((R_NSMAX+2-JN)-KM)*2 PSPEC(JFLD,INM ) = PIA(2*JFLD-1,JN+1,KMLOC) PSPEC(JFLD,INM+1) = PIA(2*JFLD ,JN+1,KMLOC) ENDIF ENDDO ENDDO ENDDO ENDIF #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE PRFI1BAD END MODULE PRFI1BAD_MOD ectrans-1.8.0/src/trans/gpu/internal/inv_trans_ctl_mod.F900000664000175000017500000002373615174631767023710 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE INV_TRANS_CTL_MOD CONTAINS SUBROUTINE INV_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& & KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANS_CTL* - Control routine for inverse spectral transform. ! Purpose. ! -------- ! Control routine for the inverse spectral transform !** Interface. ! ---------- ! CALL INV_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! 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. ! FSPGL_PROC - external procedure to be executed in fourier space ! before transposition ! PGP(:,:,:) - gridpoint fields (output) ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! vorticity : KF_UV_G fields ! divergence : KF_UV_G fields ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! N-S derivative of scalar fields : KF_SCALARS_G fields ! E-W derivative of u : KF_UV_G fields ! E-W derivative of v : KF_UV_G fields ! E-W derivative of scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPRD USE TPM_GEN, ONLY: NPROMATR USE TPM_TRANS, ONLY: LDIVGP, LSCDERS, LUVDER, LVORGP, GROWING_ALLOCATION USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, MAKE_BUFFERED_ALLOCATOR, & & INSTANTIATE_ALLOCATOR USE TRMTOL_MOD, ONLY: PREPARE_TRMTOL, TRMTOL_HANDLE, TRMTOL USE LTINV_MOD, ONLY: PREPARE_LTINV, LTINV_HANDLE, LTINV USE TRMTOL_PACK_UNPACK, ONLY: TRMTOL_PACK_HANDLE, TRMTOL_UNPACK_HANDLE, & & PREPARE_TRMTOL_PACK, PREPARE_TRMTOL_UNPACK, TRMTOL_PACK, & & TRMTOL_UNPACK USE FSC_MOD, ONLY: FSC USE FTINV_MOD, ONLY: FTINV_HANDLE, PREPARE_FTINV, FTINV USE TRLTOG_MOD, ONLY: TRLTOG_HANDLE, PREPARE_TRLTOG, TRLTOG IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) 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(:) REAL(KIND=JPRB) ,OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) ! Local variables REAL(KIND=JPRB), POINTER :: FOUBUF(:), FOUBUF_IN(:) REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:), PREEL_COMPLEX(:) REAL(KIND=JPRBT), POINTER :: ZOUTS(:), ZOUTA(:) REAL(KIND=JPRD), POINTER :: ZOUTS0(:), ZOUTA0(:) INTEGER(KIND=JPIM) :: KUV_OFFSET, KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET, & & KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET INTEGER(KIND=JPIM) :: IF_LEG, IF_FOURIER INTEGER(KIND=JPIM) :: IFIRST TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR TYPE(LTINV_HANDLE) :: HLTINV TYPE(TRMTOL_PACK_HANDLE) :: HTRMTOL_PACK TYPE(TRMTOL_HANDLE) :: HTRMTOL TYPE(TRMTOL_UNPACK_HANDLE) :: HTRMTOL_UNPACK TYPE(FTINV_HANDLE) :: HFTINV TYPE(TRLTOG_HANDLE) :: HTRLTOG ! ------------------------------------------------------------------ IF (NPROMATR > 0) THEN CALL ABORT_TRANS("NPROMATR > 0 not supported for GPU") ENDIF ! Compute Vertical domain decomposition ! Initialize potentially unset offsets KSCALARS_NSDER_OFFSET = -1 KUV_EWDER_OFFSET = -1 KSCALARS_EWDER_OFFSET = -1 ! (note in ltinv we will initially start with a slightly different domain decomposition ! which always has vorticity and divergence because this is the actual input) IFIRST = 0 IF (LVORGP) IFIRST = IFIRST + KF_UV ! Vorticity IF (LDIVGP) IFIRST = IFIRST + KF_UV ! Divergence KUV_OFFSET = IFIRST IFIRST = IFIRST + KF_UV ! U IFIRST = IFIRST + KF_UV ! V KSCALARS_OFFSET = IFIRST IFIRST = IFIRST + KF_SCALARS ! Scalars IF (LSCDERS) THEN KSCALARS_NSDER_OFFSET = IFIRST IFIRST = IFIRST + KF_SCALARS ! Scalars NS Derivatives ENDIF ! the rest of fields is being computed in fourier space, namely in FSC IF_LEG = IFIRST IF (LUVDER) THEN KUV_EWDER_OFFSET = IFIRST IFIRST = IFIRST+2*KF_UV ! U and V derivatives ENDIF IF (LSCDERS) THEN KSCALARS_EWDER_OFFSET = IFIRST IFIRST = IFIRST + KF_SCALARS ! Scalars EW Derivatives ENDIF IF_FOURIER = IFIRST IF (IF_FOURIER /= KF_FS) CALL ABORT_TRANS('Size mismatch: Wrong computation KF_FS') ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() IF (KF_FS > 0) THEN HLTINV = PREPARE_LTINV(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) HTRMTOL_PACK = PREPARE_TRMTOL_PACK(ALLOCATOR,IF_LEG) HTRMTOL = PREPARE_TRMTOL(ALLOCATOR,IF_LEG) HTRMTOL_UNPACK = PREPARE_TRMTOL_UNPACK(ALLOCATOR,IF_FOURIER) HFTINV = PREPARE_FTINV(ALLOCATOR,IF_FOURIER) ENDIF HTRLTOG = PREPARE_TRLTOG(ALLOCATOR,IF_FOURIER,KF_GP) CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) IF (KF_FS > 0) THEN ! Legendre transformations CALL GSTATS(102,0) CALL LTINV(ALLOCATOR,HLTINV,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & & ZOUTS,ZOUTA,ZOUTS0,ZOUTA0) CALL GSTATS(102,1) ! Packing into send buffer, to fourier space and unpack CALL GSTATS(152,0) CALL TRMTOL_PACK(ALLOCATOR,HTRMTOL_PACK,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,IF_LEG) CALL TRMTOL(ALLOCATOR,HTRMTOL,FOUBUF_IN,FOUBUF,IF_LEG) CALL TRMTOL_UNPACK(ALLOCATOR,HTRMTOL_UNPACK,FOUBUF,PREEL_COMPLEX,IF_LEG,IF_FOURIER) CALL GSTATS(152,1) CALL GSTATS(107,0) ! compute NS derivatives CALL FSC(PREEL_COMPLEX, IF_FOURIER, KF_UV, KF_SCALARS, KUV_OFFSET, KSCALARS_OFFSET, & & KSCALARS_NSDER_OFFSET, KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET) !Legendre transformations CALL FTINV(ALLOCATOR, HFTINV, PREEL_COMPLEX,PREEL_REAL,IF_FOURIER) CALL GSTATS(107,1) ENDIF ! Transposition into grid-point space CALL GSTATS(157,0) CALL TRLTOG(ALLOCATOR,HTRLTOG,PREEL_REAL,IF_FOURIER,KF_GP,KF_UV_G,KF_SCALARS_G,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) CALL GSTATS(157,1) END SUBROUTINE INV_TRANS_CTL END MODULE INV_TRANS_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/trmtol_pack_unpack.F900000775000175000017500000002611315174631767024057 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRMTOL_PACK_UNPACK USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRMTOL_PACK, TRMTOL_PACK_HANDLE, PREPARE_TRMTOL_PACK PUBLIC :: TRMTOL_UNPACK, TRMTOL_UNPACK_HANDLE, PREPARE_TRMTOL_UNPACK TYPE TRMTOL_PACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF_IN END TYPE TYPE TRMTOL_UNPACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HREEL END TYPE CONTAINS FUNCTION PREPARE_TRMTOL_PACK(ALLOCATOR,KF_LEG) RESULT(HTRMTOL_PACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE ISO_C_BINDING, ONLY: C_SIZEOF USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG TYPE(TRMTOL_PACK_HANDLE) :: HTRMTOL_PACK INTEGER(KIND=JPIB) :: IALLOC_SZ REAL(KIND=JPRBT) :: ZPRBT_DUMMY IALLOC_SZ = 2_JPIB*D%NLENGT1B*KF_LEG*C_SIZEOF(ZPRBT_DUMMY) HTRMTOL_PACK%HFOUBUF_IN = RESERVE(ALLOCATOR, IALLOC_SZ, "HTRMTOL_PACK%HFOUBUF_IN") END FUNCTION SUBROUTINE TRMTOL_PACK(ALLOCATOR,HTRMTOL_PACK,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,KF_LEG) !**** *TRMTOL_PACK* - Packing buffer for TRMTOL ! Purpose. ! -------- ! Packs data from LTINV outputs into FOUBUF for conversion to fourier space !** Interface. ! ---------- ! CALL TRMTOL_PACK(...) ! Explicit arguments : ZOUTS - symmetric data ! -------------------- ZOUTA - asymmetric data ! ZOUTS0 - symmetric data for KMLOC0 ! ZOUTA0 - asymmetric data for KMLOC0 ! FOUBUF_IN - output towards TRMTOL ! KF_LEG - number of fields (we have 2XKF_LEG because complex) ! Implicit arguments : None. ! -------------------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Nils Wedi + Mats Hamrud + George Modzynski ! ! Modifications. ! -------------- ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPRD, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE TPM_DISTR, ONLY: D USE LEINV_MOD, ONLY: LEINV_STRIDES USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE ! DUMMY ARGUMENTS TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRMTOL_PACK_HANDLE), INTENT(IN) :: HTRMTOL_PACK REAL(KIND=JPRB), INTENT(OUT), POINTER :: FOUBUF_IN(:) REAL(KIND=JPRBT), INTENT(IN) :: ZOUTS(:), ZOUTA(:) REAL(KIND=JPRD), INTENT(IN) :: ZOUTS0(:), ZOUTA0(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG ! LOCAL REAL(KIND=JPRBT) :: ZAOA, ZSOA INTEGER(KIND=JPIM) :: KMLOC, KM, ISL, JGL, JK, IGLS INTEGER(KIND=JPIB) :: OFFSET1, OFFSET2 INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ASSOCIATE(D_NUMP=>D%NUMP, R_NDGNH=>R%NDGNH, R_NDGL=>R%NDGL, G_NDGLU=>G%NDGLU, & & D_MYMS=>D%MYMS, D_NPNTGTB1=>D%NPNTGTB1, D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1) IF (LHOOK) CALL DR_HOOK('TRMTOL_PACK',0,ZHOOK_HANDLE) CALL ASSIGN_PTR(FOUBUF_IN, GET_ALLOCATION(ALLOCATOR, HTRMTOL_PACK%HFOUBUF_IN),& & 1_JPIB, 2_JPIB*D%NLENGT1B*KF_LEG*C_SIZEOF(FOUBUF_IN(1))) CALL LEINV_STRIDES(KF_LEG,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:D,D_MYMS,D_NPNTGTB1,D_NUMP,G,G_NDGLU,R,R_NDGNH,R_NDGL) & !$OMP& MAP(PRESENT,ALLOC:ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,D_OFFSETS_GEMM1) #endif #ifdef ACCGPU !$ACC DATA PRESENT(D,D_MYMS,D_NPNTGTB1,D_NUMP,G,G_NDGLU,R,R_NDGNH,R_NDGL) & !$ACC& PRESENT(ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,D_OFFSETS_GEMM1) #endif #ifdef OMPGPU ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) & !$OMP& SHARED(D,R,G,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN) & !$OMP& PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,ZAOA,ZSOA) & !$OMP& MAP(TO:KF_LEG,IOUT_STRIDES0,IOUT0_STRIDES0) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,ZAOA,ZSOA) & !$ACC& FIRSTPRIVATE(KF_LEG,IOUT_STRIDES0,IOUT0_STRIDES0) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JGL=1,R_NDGNH DO JK=1,2*KF_LEG KM = D_MYMS(KMLOC) ISL = R_NDGNH-G_NDGLU(KM)+1 IF (JGL >= ISL) THEN !(DO JGL=ISL,R_NDGNH) IGLS = R_NDGL+1-JGL OFFSET1 = 2_JPIB*D_NPNTGTB1(KMLOC,JGL )*KF_LEG OFFSET2 = 2_JPIB*D_NPNTGTB1(KMLOC,IGLS)*KF_LEG IF(KM /= 0) THEN ZSOA = ZOUTS(JK+(JGL-ISL)*IOUT_STRIDES0+D_OFFSETS_GEMM1(KMLOC)*IOUT_STRIDES0) ZAOA = ZOUTA(JK+(JGL-ISL)*IOUT_STRIDES0+D_OFFSETS_GEMM1(KMLOC)*IOUT_STRIDES0) ELSEIF (MOD((JK-1),2) == 0) THEN ZSOA = ZOUTS0((JK-1)/2+1+(JGL-1)*IOUT0_STRIDES0) ZAOA = ZOUTA0((JK-1)/2+1+(JGL-1)*IOUT0_STRIDES0) ELSE ! Imaginary values of KM=0 is zero, though I don't think we care ZSOA = 0_JPRBT ZAOA = 0_JPRBT ENDIF FOUBUF_IN(OFFSET1+JK) = ZAOA+ZSOA FOUBUF_IN(OFFSET2+JK) = ZSOA-ZAOA ENDIF ENDDO ENDDO ENDDO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('TRMTOL_PACK',1,ZHOOK_HANDLE) END ASSOCIATE END SUBROUTINE TRMTOL_PACK FUNCTION PREPARE_TRMTOL_UNPACK(ALLOCATOR,KF_FS) RESULT(HTRMTOL_UNPACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM) :: KF_FS TYPE(TRMTOL_UNPACK_HANDLE) :: HTRMTOL_UNPACK REAL(KIND=JPRBT) :: DUMMY HTRMTOL_UNPACK%HREEL = RESERVE(ALLOCATOR, 1_JPIB*D%NLENGTF*KF_FS*C_SIZEOF(DUMMY), "HTRMTOL_UNPACK%HREEL") END FUNCTION PREPARE_TRMTOL_UNPACK SUBROUTINE TRMTOL_UNPACK(ALLOCATOR,HTRMTOL_UNPACK,FOUBUF,PREEL_COMPLEX,KF_CURRENT,KF_TOTAL) !**** *TRMTOL_UNPACK* - Copy fourier data from buffer to local array ! Purpose. ! -------- ! Routine for copying fourier data from buffer to local array !** Interface. ! ---------- ! CALL TRMTOL_UNPACK(...) ! Explicit arguments : PREEL_COMPLEX - local fourier/GP array ! -------------------- KF_CURRENT - number of fields that are read (from Legendre space) ! KF_TOTAL - total fields in PREEL ("stride") ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D, MYSETW USE TPM_GEOMETRY, ONLY: G USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_SIZEOF ! IMPLICIT NONE REAL(KIND=JPRBT), INTENT(IN) :: FOUBUF(:) REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KF_CURRENT, KF_TOTAL TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRMTOL_UNPACK_HANDLE), INTENT(IN) :: HTRMTOL_UNPACK INTEGER(KIND=JPIM) :: JM,JF,IGLG,OFFSET_VAR,KGL,ILOEN_MAX INTEGER(KIND=JPIB) :: IOFF_LAT, ISTA REAL(KIND=JPRBT) :: RET_REAL, RET_COMPLEX ASSOCIATE(D_NDGL_FS=>D%NDGL_FS, D_NSTAGTF=>D%NSTAGTF, D_NPNTGTB0=>D%NPNTGTB0, D_NPTRLS=>D%NPTRLS, & & G_NLOEN=>G%NLOEN, G_NMEN=>G%NMEN) CALL ASSIGN_PTR(PREEL_COMPLEX, GET_ALLOCATION(ALLOCATOR, HTRMTOL_UNPACK%HREEL),& & 1_JPIB, 1_JPIB*KF_TOTAL*D%NLENGTF*C_SIZEOF(PREEL_COMPLEX(1))) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:G,G_NLOEN,G_NMEN,D,D_NPNTGTB0,FOUBUF,PREEL_COMPLEX,D_NSTAGTF,D_NDGL_FS) #endif #ifdef ACCGPU !$ACC DATA PRESENT(G,G_NLOEN,G_NMEN,D,D_NPNTGTB0,FOUBUF,PREEL_COMPLEX,D_NSTAGTF,D_NDGL_FS) ASYNC(1) #endif OFFSET_VAR=D_NPTRLS(MYSETW) ILOEN_MAX=MAXVAL(G_NLOEN) #ifdef OMPGPU ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) & !$OMP& SHARED(D,G,KF_CURRENT,ILOEN_MAX,OFFSET_VAR,FOUBUF,PREEL_COMPLEX) & !$OMP& PRIVATE(IGLG,IOFF_LAT,ISTA,RET_REAL,RET_COMPLEX) & !$OMP& MAP(TO:KF_CURRENT,ILOEN_MAX,OFFSET_VAR,KF_TOTAL) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP PRIVATE(IGLG,IOFF_LAT,ISTA,RET_REAL,RET_COMPLEX) FIRSTPRIVATE(KF_CURRENT,& !$ACC& KF_TOTAL,OFFSET_VAR,ILOEN_MAX) DEFAULT(NONE) TILE(32,16,1) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KGL=1,D_NDGL_FS DO JF=1,KF_CURRENT DO JM=0,ILOEN_MAX/2 IGLG = OFFSET_VAR+KGL-1 ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have ! to fill those floor(NLON/2)+1 values. ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. IF (JM <= G_NLOEN(IGLG)/2) THEN RET_REAL = 0.0_JPRBT RET_COMPLEX = 0.0_JPRBT IF (JM <= G_NMEN(IGLG)) THEN ISTA = 2_JPIB*D_NPNTGTB0(JM,KGL)*KF_CURRENT RET_REAL = FOUBUF(ISTA+2*JF-1) RET_COMPLEX = FOUBUF(ISTA+2*JF ) ENDIF IOFF_LAT = 1_JPIB*KF_TOTAL*D_NSTAGTF(KGL)+(JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) PREEL_COMPLEX(IOFF_LAT+2*JM+1) = RET_REAL PREEL_COMPLEX(IOFF_LAT+2*JM+2) = RET_COMPLEX ENDIF ENDDO ENDDO ENDDO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA !$ACC WAIT(1) #endif END ASSOCIATE END SUBROUTINE TRMTOL_UNPACK END MODULE TRMTOL_PACK_UNPACK ectrans-1.8.0/src/trans/gpu/internal/ftinv_mod.F900000775000175000017500000001046415174631767022166 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE FTINV_MOD USE BUFFERED_ALLOCATOR_MOD ,ONLY : BUFFERED_ALLOCATOR, ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: FTINV, FTINV_HANDLE, PREPARE_FTINV TYPE FTINV_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HREEL_REAL END TYPE CONTAINS FUNCTION PREPARE_FTINV(ALLOCATOR,KF_FS) RESULT(HFTINV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(FTINV_HANDLE) :: HFTINV REAL(KIND=JPRBT) :: DUMMY #ifndef IN_PLACE_FFT HFTINV%HREEL_REAL = RESERVE(ALLOCATOR, 1_JPIB*D%NLENGTF*KF_FS*C_SIZEOF(DUMMY),"HFTINV%HREEL_REAL") #endif END FUNCTION SUBROUTINE FTINV(ALLOCATOR,HFTINV,PREEL_COMPLEX,PREEL_REAL,KFIELD) !**** *FTINV - Inverse Fourier transform ! Purpose. Routine for Fourier to Grid-point transform ! -------- !** Interface. ! ---------- ! CALL FTINV(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELD - number of fields ! Method. ! ------- ! Externals. FFT992 - FFT routine ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti 01-04-24 2D model (NLOEN=1) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW ! ------------------------------------------------------------------ USE TPM_GEN, ONLY: LSYNC_TRANS, NCUR_RESOL USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: MYSETW, D USE TPM_GEOMETRY, ONLY: G USE TPM_HICFFT, ONLY: EXECUTE_INV_FFT USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE BUFFERED_ALLOCATOR_MOD, ONLY: ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRBT), INTENT(INOUT), POINTER :: PREEL_REAL(:) REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PREEL_COMPLEX(:) TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(FTINV_HANDLE), INTENT(IN) :: HFTINV INTEGER(KIND=JPIM) :: KGL ASSOCIATE(D_NDGL_FS=>D%NDGL_FS, D_NPTRLS=>D%NPTRLS, D_NSTAGTF=>D%NSTAGTF, G_NLOEN=>G%NLOEN) #ifdef IN_PLACE_FFT PREEL_REAL => PREEL_COMPLEX #else CALL ASSIGN_PTR(PREEL_REAL, GET_ALLOCATION(ALLOCATOR, HFTINV%HREEL_REAL),& & 1_JPIB, 1_JPIB*KFIELD*D%NLENGTF*C_SIZEOF(PREEL_REAL(1))) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PREEL_REAL,PREEL_COMPLEX,D_NPTRLS,D_NDGL_FS,D_NSTAGTF,G_NLOEN) #endif #ifdef ACCGPU !$ACC DATA PRESENT(PREEL_REAL,PREEL_COMPLEX,D_NPTRLS,D_NDGL_FS,D_NSTAGTF,G_NLOEN) #endif IF (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(423,0) CALL EXECUTE_INV_FFT(PREEL_COMPLEX,PREEL_REAL,NCUR_RESOL,KFIELD, & & LOENS=G_NLOEN(D_NPTRLS(MYSETW):D_NPTRLS(MYSETW)+D_NDGL_FS-1), & & OFFSETS=D_NSTAGTF(1:D_NDGL_FS),ALLOC=ALLOCATOR%PTR) IF (LSYNC_TRANS) THEN CALL GSTATS(443,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(443,1) ENDIF CALL GSTATS(423,1) #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif NULLIFY(PREEL_COMPLEX) END ASSOCIATE ! ------------------------------------------------------------------ END SUBROUTINE FTINV END MODULE FTINV_MOD ectrans-1.8.0/src/trans/gpu/internal/uvtvd_mod.F900000775000175000017500000001235215174631767022206 0ustar alastairalastair! (C) Copyright 1991- ECMWF. ! (C) Copyright 1991- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE UVTVD_MOD CONTAINS SUBROUTINE UVTVD(KF_UV,PU,PV,PVOR,PDIV) !**** *UVTVD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX. !** Interface. ! ---------- ! CALL UVTVD(KM,KF_UV,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number ! -------------------- KF_UV - number of fields (levels) ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE TPM_FIELDS_GPU, ONLY: FG ! IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV REAL(KIND=JPRBT), INTENT(OUT) :: PVOR(:,:,:),PDIV(:,:,:) REAL(KIND=JPRBT), INTENT(INOUT) :: PU (:,:,:),PV (:,:,:) INTEGER(KIND=JPIM) :: KM, KMLOC ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IN, IR, J, JN ! LOCAL REAL SCALARS REAL(KIND=JPRBT) :: ZKM,ZJN ! ------------------------------------------------------------------ ASSOCIATE(D_NUMP=>D%NUMP, R_NTMAX=>R%NTMAX, D_MYMS=>D%MYMS, ZEPSNM=>FG%ZEPSNM) !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:D,D_MYMS,D_NUMP,R,R_NTMAX,FG,ZEPSNM,PU,PV,PVOR,PDIV) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(D,D_MYMS,D_NUMP,R,R_NTMAX) & !$ACC& PRESENT(FG,ZEPSNM,PU,PV,PVOR,PDIV) ASYNC(1) #endif !* 1.1 SET N=KM-1 COMPONENT TO 0 FOR U AND V #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) PRIVATE(KM) SHARED(D,KF_UV,R,PU,PV) & !$OMP& MAP(TO:KF_UV) DEFAULT(NONE) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM) FIRSTPRIVATE(KF_UV) DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO J=1,2*KF_UV KM = D_MYMS(KMLOC) PU(J,R_NTMAX+4-KM,KMLOC) = 0.0_JPRBT PV(J,R_NTMAX+4-KM,KMLOC) = 0.0_JPRBT ENDDO ENDDO !* 1.2 COMPUTE VORTICITY AND DIVERGENCE. #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) PRIVATE(IR,II,IN,KM,ZKM,ZJN) & !$OMP& SHARED(D,R,KF_UV,FG,PVOR,PV,PU,PDIV) DEFAULT(NONE) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IR,II,IN,KM,ZKM,ZJN) FIRSTPRIVATE(KF_UV) DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=0,R_NTMAX DO J=1,KF_UV IR = 2*J-1 II = IR+1 KM = D_MYMS(KMLOC) ZKM = REAL(KM,JPRBT) IF(KM /= 0 .AND. JN >= KM) THEN ! (DO JN=KN,R_NTMAX) IN = R_NTMAX+3-JN ZJN = JN PVOR(IR,IN,KMLOC) = -ZKM*PV(II,IN,KMLOC)-& &ZJN*ZEPSNM(KMLOC,JN+1)*PU(IR,IN-1,KMLOC)+& &(ZJN+1)*ZEPSNM(KMLOC,JN)*PU(IR,IN+1,KMLOC) PVOR(II,IN,KMLOC) = +ZKM*PV(IR,IN,KMLOC)-& &ZJN*ZEPSNM(KMLOC,JN+1)*PU(II,IN-1,KMLOC)+& &(ZJN+1)*ZEPSNM(KMLOC,JN)*PU(II,IN+1,KMLOC) PDIV(IR,IN,KMLOC) = -ZKM*PU(II,IN,KMLOC)+& &ZJN*ZEPSNM(KMLOC,JN+1)*PV(IR,IN-1,KMLOC)-& &(ZJN+1)*ZEPSNM(KMLOC,JN)*PV(IR,IN+1,KMLOC) PDIV(II,IN,KMLOC) = +ZKM*PU(IR,IN,KMLOC)+& &ZJN*ZEPSNM(KMLOC,JN+1)*PV(II,IN-1,KMLOC)-& &(ZJN+1)*ZEPSNM(KMLOC,JN)*PV(II,IN+1,KMLOC) ELSEIF(KM == 0) THEN ! (DO JN=0,R_NTMAX) IN = R_NTMAX+3-JN ZJN = JN PVOR(IR,IN,KMLOC) = -& &ZJN*ZEPSNM(KMLOC,JN+1)*PU(IR,IN-1,KMLOC)+& &(ZJN+1)*ZEPSNM(KMLOC,JN)*PU(IR,IN+1,KMLOC) PDIV(IR,IN,KMLOC) = & &ZJN*ZEPSNM(KMLOC,JN+1)*PV(IR,IN-1,KMLOC)-& &(ZJN+1)*ZEPSNM(KMLOC,JN)*PV(IR,IN+1,KMLOC) ENDIF ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE UVTVD END MODULE UVTVD_MOD ectrans-1.8.0/src/trans/gpu/internal/trmtolad_pack_unpack.F900000775000175000017500000003337315174631767024372 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRMTOLAD_PACK_UNPACK USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRMTOLAD_PACK, TRMTOLAD_PACK_HANDLE, PREPARE_TRMTOLAD_PACK PUBLIC :: TRMTOLAD_UNPACK, TRMTOLAD_UNPACK_HANDLE, PREPARE_TRMTOLAD_UNPACK TYPE TRMTOLAD_PACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HOUTS_AND_OUTA END TYPE TYPE TRMTOLAD_UNPACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPFBUF END TYPE CONTAINS FUNCTION PREPARE_TRMTOLAD_PACK(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) RESULT(HTRMTOLAD_PACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE TPM_DISTR, ONLY: D USE TPM_DIM, ONLY: R USE ISO_C_BINDING, ONLY: C_SIZEOF USE LEINV_MOD, ONLY: LEINV_STRIDES USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS LOGICAL, INTENT(IN) :: LVORGP,LDIVGP,LSCDERS TYPE(TRMTOLAD_PACK_HANDLE) :: HTRMTOLAD_PACK INTEGER(KIND=JPIB) :: IALLOC_SZ INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE REAL(KIND=JPRBT) :: ZPRBT_DUMMY REAL(KIND=JPRD) :: ZPRD_DUMMY INTEGER(KIND=JPIM) :: IF_READIN, IF_LEG ! # fields that are initially read. We always read vorticity ! and divergence! Also keep in mind that we actually have 2X ! this number of levels because real+complex IF_READIN = 0 IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! Vorticity or divergence IF_READIN = IF_READIN + KF_UV ! U IF_READIN = IF_READIN + KF_UV ! V IF_READIN = IF_READIN + KF_SCALARS ! Scalars IF (LSCDERS) & IF_READIN = IF_READIN + KF_SCALARS ! Scalars NS Derivatives ! In Legendre space, we then ignore vorticity/divergence, if ! they don't need to be transformed. IF_LEG = IF_READIN IF(.NOT. LVORGP) IF_LEG = IF_LEG - KF_UV ! No vorticity needed IF(.NOT. LDIVGP) IF_LEG = IF_LEG - KF_UV ! No divergence needed CALL LEINV_STRIDES(IF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) IALLOC_SZ = 0 ! ZOUTA IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUTS IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT_SIZE*C_SIZEOF(ZPRBT_DUMMY),128) ! ZOUTA0 IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) ! ZOUTS0 IALLOC_SZ = IALLOC_SZ + ALIGN(IOUT0_SIZE*C_SIZEOF(ZPRD_DUMMY),128) HTRMTOLAD_PACK%HOUTS_AND_OUTA = RESERVE(ALLOCATOR, IALLOC_SZ, "HTRMTOLAD_PACK%HOUTS_AND_OUTA") END FUNCTION SUBROUTINE TRMTOLAD_PACK(ALLOCATOR,HTRMTOL_PACK,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,KF_LEG) !**** *TRMTOL_PACK* - Packing buffer for TRMTOL ! Purpose. ! -------- ! Packs data from LTINV outputs into FOUBUF for conversion to fourier space !** Interface. ! ---------- ! CALL TRMTOL_PACK(...) ! Explicit arguments : ZOUTS - symmetric data ! -------------------- ZOUTA - asymmetric data ! ZOUTS0 - symmetric data for KMLOC0 ! ZOUTA0 - asymmetric data for KMLOC0 ! FOUBUF_IN - output towards TRMTOL ! KF_LEG - number of fields (we have 2XKF_LEG because complex) ! Implicit arguments : None. ! -------------------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Nils Wedi + Mats Hamrud + George Modzynski ! ! Modifications. ! -------------- ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPRD, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE TPM_DISTR, ONLY: D USE LEINV_MOD, ONLY: LEINV_STRIDES USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE ! DUMMY ARGUMENTS TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRMTOLAD_PACK_HANDLE), INTENT(IN) :: HTRMTOL_PACK REAL(KIND=JPRB), INTENT(IN) :: FOUBUF_IN(:) REAL(KIND=JPRBT), INTENT(OUT), POINTER :: ZOUTS(:), ZOUTA(:) REAL(KIND=JPRD), INTENT(OUT), POINTER :: ZOUTS0(:), ZOUTA0(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG ! LOCAL REAL(KIND=JPRBT) :: ZAOA, ZSOA INTEGER(KIND=JPIB) :: IALLOC_POS, IALLOC_SZ INTEGER(KIND=JPIM) :: KMLOC, KM, ISL, JGL, JK, IGLS INTEGER(KIND=JPIB) :: OFFSET1, OFFSET2 INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ASSOCIATE(D_NUMP=>D%NUMP, R_NDGNH=>R%NDGNH, R_NDGL=>R%NDGL, G_NDGLU=>G%NDGLU, & & D_MYMS=>D%MYMS, D_NPNTGTB1=>D%NPNTGTB1, D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1) IF (LHOOK) CALL DR_HOOK('TRMTOLAD_PACK',0,ZHOOK_HANDLE) CALL LEINV_STRIDES(KF_LEG,IOUT_STRIDES0=IOUT_STRIDES0,IOUT_SIZE=IOUT_SIZE,& IOUT0_STRIDES0=IOUT0_STRIDES0,IOUT0_SIZE=IOUT0_SIZE) IALLOC_POS = 1 ! ZOUTA IALLOC_SZ = ALIGN(IOUT_SIZE*C_SIZEOF(ZOUTA(1)),128) CALL ASSIGN_PTR(ZOUTA, GET_ALLOCATION(ALLOCATOR, HTRMTOL_PACK%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUTS IALLOC_SZ = ALIGN(IOUT_SIZE*C_SIZEOF(ZOUTS(1)),128) CALL ASSIGN_PTR(ZOUTS, GET_ALLOCATION(ALLOCATOR, HTRMTOL_PACK%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUTA0 IALLOC_SZ = ALIGN(IOUT0_SIZE*C_SIZEOF(ZOUTA0(1)),128) CALL ASSIGN_PTR(ZOUTA0, GET_ALLOCATION(ALLOCATOR, HTRMTOL_PACK%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ ! ZOUTS0 IALLOC_SZ = ALIGN(IOUT0_SIZE*C_SIZEOF(ZOUTS0(1)),128) CALL ASSIGN_PTR(ZOUTS0, GET_ALLOCATION(ALLOCATOR, HTRMTOL_PACK%HOUTS_AND_OUTA),& & IALLOC_POS, IALLOC_SZ) IALLOC_POS = IALLOC_POS + IALLOC_SZ #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:D,D_MYMS,D_NPNTGTB1,D_NUMP,G,G_NDGLU,R,R_NDGNH,R_NDGL) & !$OMP& MAP(PRESENT,ALLOC:ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,D_OFFSETS_GEMM1) #endif #ifdef ACCGPU !$ACC DATA PRESENT(D,D_MYMS,D_NPNTGTB1,D_NUMP,G,G_NDGLU,R,R_NDGNH,R_NDGL) & !$ACC& PRESENT(ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,D_OFFSETS_GEMM1) #endif #ifdef OMPGPU ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) & !$OMP& SHARED(D,R,G,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN) & !$OMP& PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,ZAOA,ZSOA) & !$OMP& MAP(TO:KF_LEG,IOUT_STRIDES0,IOUT0_STRIDES0) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,ZAOA,ZSOA) & !$ACC& FIRSTPRIVATE(KF_LEG,IOUT_STRIDES0,IOUT0_STRIDES0) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JGL=1,R_NDGNH DO JK=1,2*KF_LEG KM = D_MYMS(KMLOC) ISL = R_NDGNH-G_NDGLU(KM)+1 IF (JGL >= ISL) THEN !(DO JGL=ISL,R_NDGNH) IGLS = R_NDGL+1-JGL OFFSET1 = 2_JPIB*D_NPNTGTB1(KMLOC,JGL )*KF_LEG OFFSET2 = 2_JPIB*D_NPNTGTB1(KMLOC,IGLS)*KF_LEG ZSOA = FOUBUF_IN(OFFSET1+JK) + FOUBUF_IN(OFFSET2+JK) ZAOA = FOUBUF_IN(OFFSET1+JK) - FOUBUF_IN(OFFSET2+JK) IF(KM /= 0) THEN ZOUTS(JK+(JGL-ISL)*IOUT_STRIDES0+D_OFFSETS_GEMM1(KMLOC)*IOUT_STRIDES0) = ZSOA ZOUTA(JK+(JGL-ISL)*IOUT_STRIDES0+D_OFFSETS_GEMM1(KMLOC)*IOUT_STRIDES0) = ZAOA ELSEIF (MOD((JK-1),2) == 0) THEN ZOUTS0((JK-1)/2+1+(JGL-1)*IOUT0_STRIDES0) = ZSOA ZOUTA0((JK-1)/2+1+(JGL-1)*IOUT0_STRIDES0) = ZAOA ELSE ! Imaginary values of KM=0 is zero, though I don't think we care ! ZSOA = 0_JPRBT ! ZAOA = 0_JPRBT ENDIF ENDIF ENDDO ENDDO ENDDO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('TRMTOLAD_PACK',1,ZHOOK_HANDLE) END ASSOCIATE END SUBROUTINE TRMTOLAD_PACK FUNCTION PREPARE_TRMTOLAD_UNPACK(ALLOCATOR,KF_LEG) RESULT(HTRMTOLAD_UNPACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM) :: KF_LEG TYPE(TRMTOLAD_UNPACK_HANDLE) :: HTRMTOLAD_UNPACK REAL(KIND=JPRBT) :: DUMMY HTRMTOLAD_UNPACK%HPFBUF = RESERVE(ALLOCATOR, 2_JPIB*D%NLENGT0B*KF_LEG*C_SIZEOF(DUMMY), "HTRMTOLAD_UNPACK%HPFBUF") END FUNCTION PREPARE_TRMTOLAD_UNPACK SUBROUTINE TRMTOLAD_UNPACK(ALLOCATOR,HTRMTOL_UNPACK,FOUBUF,PREEL_COMPLEX,KF_CURRENT,KF_TOTAL) !**** *TRMTOL_UNPACK* - Copy fourier data from buffer to local array ! Purpose. ! -------- ! Routine for copying fourier data from buffer to local array !** Interface. ! ---------- ! CALL TRMTOL_UNPACK(...) ! Explicit arguments : PREEL_COMPLEX - local fourier/GP array ! -------------------- KF_CURRENT - number of fields that are read (from Legendre space) ! KF_TOTAL - total fields in PREEL ("stride") ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D, MYSETW USE TPM_GEOMETRY, ONLY: G USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE ISO_C_BINDING, ONLY: C_SIZEOF ! IMPLICIT NONE REAL(KIND=JPRBT), INTENT(OUT), POINTER :: FOUBUF(:) REAL(KIND=JPRBT), INTENT(IN) :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KF_CURRENT, KF_TOTAL TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRMTOLAD_UNPACK_HANDLE), INTENT(IN) :: HTRMTOL_UNPACK INTEGER(KIND=JPIM) :: JM,JF,IGLG,OFFSET_VAR,KGL,ILOEN_MAX INTEGER(KIND=JPIB) :: IOFF_LAT, ISTA ASSOCIATE(D_NDGL_FS=>D%NDGL_FS, D_NSTAGTF=>D%NSTAGTF, D_NPNTGTB0=>D%NPNTGTB0, D_NPTRLS=>D%NPTRLS, & & G_NLOEN=>G%NLOEN, G_NMEN=>G%NMEN) CALL ASSIGN_PTR(FOUBUF, GET_ALLOCATION(ALLOCATOR, HTRMTOL_UNPACK%HPFBUF),& & 1_JPIB, 2_JPIB*D%NLENGT0B*KF_CURRENT*C_SIZEOF(FOUBUF(1))) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:G,G_NLOEN,G_NMEN,D,D_NPNTGTB0,FOUBUF,PREEL_COMPLEX,D_NSTAGTF,D_NDGL_FS) #endif #ifdef ACCGPU !$ACC DATA PRESENT(G,G_NLOEN,G_NMEN,D,D_NPNTGTB0,FOUBUF,PREEL_COMPLEX,D_NSTAGTF,D_NDGL_FS) ASYNC(1) #endif OFFSET_VAR=D_NPTRLS(MYSETW) ILOEN_MAX=MAXVAL(G_NLOEN) #ifdef OMPGPU ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) & !$OMP& SHARED(D,G,KF_CURRENT,ILOEN_MAX,OFFSET_VAR,FOUBUF,PREEL_COMPLEX) & !$OMP& PRIVATE(IGLG,IOFF_LAT,ISTA) & !$OMP& MAP(TO:KF_CURRENT,ILOEN_MAX,OFFSET_VAR,KF_TOTAL) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP PRIVATE(IGLG,IOFF_LAT,ISTA) FIRSTPRIVATE(KF_CURRENT,& !$ACC& KF_TOTAL,OFFSET_VAR,ILOEN_MAX) DEFAULT(NONE) TILE(32,16,1) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KGL=1,D_NDGL_FS DO JF=1,KF_CURRENT DO JM=0,ILOEN_MAX/2 IGLG = OFFSET_VAR+KGL-1 ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have ! to fill those floor(NLON/2)+1 values. ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. IF (JM <= G_NLOEN(IGLG)/2) THEN IOFF_LAT = 1_JPIB*KF_TOTAL*D_NSTAGTF(KGL)+(JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) IF (JM <= G_NMEN(IGLG)) THEN ISTA = 2_JPIB*D_NPNTGTB0(JM,KGL)*KF_CURRENT FOUBUF(ISTA+2*JF-1) = PREEL_COMPLEX(IOFF_LAT+2*JM+1) FOUBUF(ISTA+2*JF ) = PREEL_COMPLEX(IOFF_LAT+2*JM+2) ENDIF ENDIF ENDDO ENDDO ENDDO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA !$ACC WAIT(1) #endif END ASSOCIATE END SUBROUTINE TRMTOLAD_UNPACK END MODULE TRMTOLAD_PACK_UNPACK ectrans-1.8.0/src/trans/gpu/internal/vd2uv_mod.F900000775000175000017500000000520315174631767022101 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE VD2UV_MOD CONTAINS SUBROUTINE VD2UV(KM,KMLOC,KF_UV,KLEI2,PSPVOR,PSPDIV,PU,PV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS !**** *VD2UV* - U and V from Vor/div ! ! Purpose. ! -------- ! !** Interface. ! ---------- ! *CALL* *VD2UV(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PU(:,:) - spectral U (out) ! PV(:,:) - spectral V (out) ! Implicit arguments : ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1B - prepares the spectral fields ! VDTUV - compute u and v from vorticity and divergence ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 ! ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 REAL(KIND=JPRB) , INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) , INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PU(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PV(:,:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('VD2UV_MOD',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !* 1. PREPARE ZEPSNM. ! --------------- CALL ABORT_TRANS('VD2UV: Code path not (yet) supported in GPU version') IF (LHOOK) CALL DR_HOOK('VD2UV_MOD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE VD2UV END MODULE VD2UV_MOD ectrans-1.8.0/src/trans/gpu/internal/trmtolad_mod.F900000775000175000017500000002151615174631767022666 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRMTOLAD_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRMTOLAD, PREPARE_TRMTOLAD, TRMTOLAD_HANDLE TYPE TRMTOLAD_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF_IN END TYPE CONTAINS FUNCTION PREPARE_TRMTOLAD(ALLOCATOR, KF_LEG) RESULT(HTRMTOLAD) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG TYPE(TRMTOLAD_HANDLE) :: HTRMTOLAD INTEGER(KIND=JPIB) :: IALLOC_SZ REAL(KIND=JPRBT) :: DUMMY IALLOC_SZ = 2_JPIB*D%NLENGT1B*KF_LEG*C_SIZEOF(DUMMY) HTRMTOLAD%HFOUBUF_IN = RESERVE(ALLOCATOR, IALLOC_SZ, "HTRMTOLAD%HFOUBUF_IN") END FUNCTION SUBROUTINE TRMTOLAD(ALLOCATOR,HTRMTOLAD,PFBUF_IN,PFBUF,KF_LEG) !**** *TRMTOLAD * - transposition in Fourier space ! Purpose. ! -------- ! Transpose Fourier buffer data from partitioning ! over wave numbers to partitioning over latitudes. ! It is called between direct FFT and direct Legendre ! transform. ! This routine is the inverse of TRLTOMAD. !** Interface. ! ---------- ! *CALL* *TRMTOLAD(...)* ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is ! -------------------- used for both input and output. ! KF_LEG - Number of fields communicated ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified : 97-06-17 G. Mozdzynski - control MPI mailbox use ! (NCOMBFLEN) for nphase.eq.1 ! Modified : 99-05-28 D.Salmond - Optimise copies. ! Modified : 00-02-02 M.Hamrud - Remove NPHASE ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message ! passing and buffer packing ! G.Mozdzynski: 08-01-01 Cleanup ! Y.Seity : 07-08-31 add barrier synchronisation under LSYNC_TRANS ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK USE TPM_DISTR, ONLY: D, NPRTRW, NPROC, MYSETW USE TPM_GEN, ONLY: LSYNC_TRANS, NERR, LMPOFF #ifdef USE_RAW_MPI USE MPI_F08, ONLY: MPI_COMM, MPI_REAL4, MPI_REAL8 ! Missing: MPI_ALLTOALLV on purpose due to cray-mpi bug (see https://github.com/ecmwf-ifs/ectrans/pull/157) #endif USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE ISO_C_BINDING, ONLY: C_SIZEOF USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_LEG REAL(KIND=JPRBT), INTENT(IN) :: PFBUF(:) REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PFBUF_IN(:) INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) INTEGER(KIND=JPIM) :: J, FROM_SEND, TO_SEND, FROM_RECV, TO_RECV, IRANK INTEGER(KIND=JPIB) :: JPOS, ISTA, IEND, ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IERROR TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRMTOLAD_HANDLE), INTENT(IN) :: HTRMTOLAD #ifdef USE_RAW_MPI TYPE(MPI_COMM) :: LOCAL_COMM #endif #ifdef PARKINDTRANS_SINGLE #define TRMTOLAD_DTYPE MPI_REAL4 #else #define TRMTOLAD_DTYPE MPI_REAL8 #endif #ifdef USE_RAW_MPI IF(.NOT. LMPOFF) THEN LOCAL_COMM%MPI_VAL = MPL_ALL_MS_COMM ENDIF #endif IF (LHOOK) CALL DR_HOOK('TRMTOLAD',0,ZHOOK_HANDLE) CALL ASSIGN_PTR(PFBUF_IN, GET_ALLOCATION(ALLOCATOR, HTRMTOLAD%HFOUBUF_IN),& & 1_JPIB, 2_JPIB*D%NLENGT1B*KF_LEG*C_SIZEOF(PFBUF_IN(1))) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PFBUF,PFBUF_IN) #endif #ifdef ACCGPU !$ACC DATA PRESENT(PFBUF,PFBUF_IN) #endif IF(NPROC > 1) THEN DO J=1,NPRTRW ILENS(J) = D%NLTSFTB(J)*2*KF_LEG IOFFS(J) = D%NSTAGT1B(J)*2*KF_LEG ILENR(J) = D%NLTSGTB(J)*2*KF_LEG IOFFR(J) = D%NSTAGT0B(J)*2*KF_LEG ENDDO CALL GSTATS(807,0) ! copy to self workaround IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) IF (ILENS(IRANK) /= ILENR(IRANK)) THEN WRITE(NERR,*) "ERROR", ILENS(IRANK), ILENR(IRANK) CALL ABORT_TRANS("TRMTOLAD: Error - ILENS(IRANK) /= ILENR(IRANK)") ENDIF IF (ILENS(IRANK) > 0) THEN FROM_SEND = IOFFS(IRANK) + 1 TO_SEND = FROM_SEND + ILENS(IRANK) - 1 FROM_RECV = IOFFR(IRANK) + 1 TO_RECV = FROM_RECV + ILENR(IRANK) - 1 #ifdef OMPGPU !$OMP TARGET TEAMS MAP(PRESENT,ALLOC:PFBUF,PFBUF_IN) MAP(TO:FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) #endif #ifdef ACCGPU #ifdef __HIP_PLATFORM_AMD__ ! Workaround for AMD GPUs - ASYNC execution of this kernel gives numerical errors !$ACC KERNELS DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) COPYIN(FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) #else !$ACC KERNELS ASYNC(1) DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) COPYIN(FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) #endif #endif PFBUF_IN(FROM_SEND:TO_SEND) = PFBUF(FROM_RECV:TO_RECV) #ifdef OMPGPU !$OMP END TARGET TEAMS #endif #ifdef ACCGPU !$ACC END KERNELS #endif ILENS(IRANK) = 0 ILENR(IRANK) = 0 ENDIF IF (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(421,0) #ifdef USE_GPU_AWARE_MPI #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_PTR(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PFBUF_IN,PFBUF) #endif #endif #ifdef USE_RAW_MPI CALL MPI_ALLTOALLV(PFBUF, ILENR, IOFFR, TRMTOLAD_DTYPE, PFBUF_IN, ILENS, IOFFS, & & TRMTOLAD_DTYPE, LOCAL_COMM,IERROR) #else CALL MPL_ALLTOALLV(PSENDBUF=PFBUF, KSENDCOUNTS=ILENR, PRECVBUF=PFBUF_IN, KRECVCOUNTS=ILENS, & & KSENDDISPL=IOFFR, KRECVDISPL=IOFFS, KCOMM=MPL_ALL_MS_COMM, & & CDSTRING='TRMTOLAD:') #endif #ifdef USE_GPU_AWARE_MPI #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE TO(PFBUF_IN) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PFBUF_IN) #endif #endif IF (LSYNC_TRANS) THEN CALL GSTATS(441,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(441,1) ENDIF CALL GSTATS(421,1) #ifdef ACCGPU #ifndef __HIP_PLATFORM_AMD__ ! Workaround for AMD GPUs - ASYNC execution of this kernel gives numerical errors !$ACC WAIT(1) #endif #endif CALL GSTATS(807,1) ELSE ILEN = 2_JPIB*D%NLTSGTB(MYSETW)*KF_LEG ISTA = 2_JPIB*D%NSTAGT0B(MYSETW)*KF_LEG+1 IEND = ISTA+ILEN-1 CALL GSTATS(1608,0) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(PFBUF,PFBUF_IN,ISTA,IEND) MAP(TO:ISTA,IEND) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) FIRSTPRIVATE(ISTA,IEND) #endif DO JPOS=ISTA,IEND PFBUF_IN(JPOS) = PFBUF(JPOS) ENDDO CALL GSTATS(1608,1) ENDIF #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('TRMTOLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRMTOLAD END MODULE TRMTOLAD_MOD ectrans-1.8.0/src/trans/gpu/internal/spnsdead_mod.F900000775000175000017500000001034515174631767022637 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE SPNSDEAD_MOD CONTAINS SUBROUTINE SPNSDEAD(KF_SCALARS,PEPSNM,PF,PNSD) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D !**** *SPNSDEAD* - Adjoint of "Compute North-South derivative in spectral space" ! Purpose. ! -------- ! In Laplace space compute the the North-south derivative !** Interface. ! ---------- ! CALL SPNSDEAD(...) ! Explicit arguments : ! -------------------- ! KM -zonal wavenumber (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PF (NLEI1,2*KF_SCALARS) - input field (input) ! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : YOMLAP ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From SPNSDE in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) :: KM, KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(1:D%NUMP,0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(INOUT) :: PF(:,:,:) REAL(KIND=JPRB), INTENT(IN) :: PNSD(:,:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: J, JN, JI, IR, II ASSOCIATE(D_NUMP=>D%NUMP, R_NTMAX=>R%NTMAX, D_MYMS=>D%MYMS) #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:R,R_NTMAX,D,D_MYMS) & !$OMP& MAP(PRESENT,ALLOC:D_NUMP,PEPSNM,PF,PNSD) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT (R,R_NTMAX, D,D_MYMS) & !$ACC& PRESENT (D_NUMP,PEPSNM, PF, PNSD) ASYNC(1) #endif ! ------------------------------------------------------------------ !* 1. COMPUTE NORTH SOUTH DERIVATIVE. ! ------------------------------- !* 1.1 COMPUTE #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(KM,IR,II,JI) MAP(TO:KF_SCALARS) SHARED(D,R,PEPSNM,PF,PNSD,KF_SCALARS) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,IR,II,JI) FIRSTPRIVATE(KF_SCALARS) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=0,R_NTMAX+1 DO J=1,KF_SCALARS IR = 2*J-1 II = IR+1 KM = D_MYMS(KMLOC) IF(KM /= 0 .AND. JN >= KM) THEN ! (DO JN=KN,R_NTMAX+1) JI = R_NTMAX+3-JN PF(IR,JI+1,KMLOC) = PF(IR,JI+1,KMLOC) - (JN-1)*PEPSNM(KMLOC,JN)*PNSD(IR,JI,KMLOC) PF(IR,JI-1,KMLOC) = PF(IR,JI-1,KMLOC) + (JN+2)*PEPSNM(KMLOC,JN+1)*PNSD(IR,JI,KMLOC) PF(II,JI+1,KMLOC) = PF(II,JI+1,KMLOC) - (JN-1)*PEPSNM(KMLOC,JN)*PNSD(II,JI,KMLOC) PF(II,JI-1,KMLOC) = PF(II,JI-1,KMLOC) + (JN+2)*PEPSNM(KMLOC,JN+1)*PNSD(II,JI,KMLOC) ELSEIF(KM == 0) THEN ! (DO JN=0,R_NTMAX+1) JI = R_NTMAX+3-JN PF(IR,JI+1,KMLOC) = PF(IR,JI+1,KMLOC) - (JN-1)*PEPSNM(KMLOC,JN)*PNSD(IR,JI,KMLOC) PF(IR,JI-1,KMLOC) = PF(IR,JI-1,KMLOC) + (JN+2)*PEPSNM(KMLOC,JN+1)*PNSD(IR,JI,KMLOC) ENDIF ENDDO ENDDO END DO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE SPNSDEAD END MODULE SPNSDEAD_MOD ectrans-1.8.0/src/trans/gpu/internal/vd2uv_ctl_mod.F900000775000175000017500000000376115174631767022752 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE VD2UV_CTL_MOD CONTAINS SUBROUTINE VD2UV_CTL(KF_UV,PSPVOR,PSPDIV,PU,PV) !**** *VD2UV_CTL* - Control routine for going from vor/div to spectral U and V. ! Purpose. ! -------- ! Control routine for computing spectral U (u*cos(theta)) and V !** Interface. ! ---------- ! CALL INV_TRANS_CTL(...) ! KF_UV - local number of spectral u-v fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PU(:,:) - U (out) ! PV(:,:) - V (out) ! Method. ! ------- ! Externals. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB USE TPM_DISTR, ONLY: D USE VD2UV_MOD, ONLY: VD2UV IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV REAL(KIND=JPRB),INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB),INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB),INTENT(OUT) :: PU(:,:) REAL(KIND=JPRB),INTENT(OUT) :: PV(:,:) INTEGER(KIND=JPIM) :: JM,IM,ILEI2 ! ------------------------------------------------------------------ CALL GSTATS(102,0) ILEI2 = 8*KF_UV CALL GSTATS(1647,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL VD2UV(IM,JM,KF_UV,ILEI2,PSPVOR,PSPDIV,PU,PV) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1647,1) CALL GSTATS(102,1) ! ------------------------------------------------------------------ END SUBROUTINE VD2UV_CTL END MODULE VD2UV_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/tpm_fields_gpu.F900000664000175000017500000000202015174631767023164 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2024- NVIDIA. ! ! 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. ! MODULE TPM_FIELDS_GPU USE EC_PARKIND, ONLY: JPRD, JPRBT IMPLICIT NONE SAVE TYPE FIELDS_GPU_TYPE ! scratch arrays for ltinv and ltdir and associated dimension variables REAL(KIND=JPRBT),ALLOCATABLE :: ZAA(:) !! JPRL for 1/2 REAL(KIND=JPRBT),ALLOCATABLE :: ZAS(:) !! JPRL for 1/2 ! for m=0 in ledir_mod: REAL(KIND=JPRD),ALLOCATABLE :: ZAA0(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAS0(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZEPSNM(:,:) END TYPE FIELDS_GPU_TYPE TYPE(FIELDS_GPU_TYPE),ALLOCATABLE,TARGET :: FIELDS_GPU_RESOL(:) TYPE(FIELDS_GPU_TYPE),POINTER :: FG END MODULE TPM_FIELDS_GPU ectrans-1.8.0/src/trans/gpu/internal/fscad_mod.F900000775000175000017500000002430515174631767022117 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE FSCAD_MOD USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D IMPLICIT NONE PRIVATE PUBLIC :: FSCAD CONTAINS SUBROUTINE FSCAD(PREEL_COMPLEX, KF_FS, KF_UV, KF_SCALARS, KUV_OFFSET, & & KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET, KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET) !**** *FSCAD - Adjoint of division by a*cos(theta), east-west derivatives computation ! Purpose. ! -------- ! In Fourier space divide u and v and all north-south ! derivatives by a*cos(theta). Also compute east-west derivatives ! of u,v,thermodynamic, passiv scalar variables and surface ! pressure. !** Interface. ! ---------- ! CALL FSCAD(..) ! Explicit arguments : KF_FS - total stride ! -------------------- KF_UV - # uv layers ! KF_SCALARS - # scalar layers ! *_OFFSET - offset of the respective layer ! ! Method. ! ------- ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 (From SC2FSC) ! ------------------------------------------------------------------ USE TPM_DISTR, ONLY: MYSETW, MYPROC, NPROC, D USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS, ONLY: F USE TPM_DIM, ONLY: R ! IMPLICIT NONE REAL(KIND=JPRBT), INTENT(INOUT) :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV, KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KUV_OFFSET, KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET INTEGER(KIND=JPIM), INTENT(IN) :: KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET INTEGER(KIND=JPIM) :: KGL REAL(KIND=JPRBT) :: ZACHTE2 INTEGER(KIND=JPIM) :: OFFSET_VAR,ILOEN_MAX INTEGER(KIND=JPIB) :: IOFF_LAT INTEGER(KIND=JPIB) :: IOFF_SCALARS,IOFF_SCALARS_EWDER,IOFF_UV,IOFF_UV_EWDER,IOFF_KSCALARS_NSDER INTEGER(KIND=JPIM) :: JF,IGLG,JM INTEGER(KIND=JPIM) :: IBEG,IEND,IINC REAL(KIND=JPRBT) :: RET_REAL, RET_COMPLEX ASSOCIATE(D_NUMP=>D%NUMP, D_NPTRLS=>D%NPTRLS, D_NSTAGTF=>D%NSTAGTF, G_NMEN=>G%NMEN, & & G_NLOEN=>G%NLOEN, F_RACTHE=>F%RACTHE, R_NSMAX=>R%NSMAX) ! ------------------------------------------------------------------ IF(MYPROC > NPROC/2)THEN IBEG=1 IEND=D%NDGL_FS IINC=1 ELSE IBEG=D%NDGL_FS IEND=1 IINC=-1 ENDIF #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:D,D_NPTRLS,D_NSTAGTF,PREEL_COMPLEX,F,F_RACTHE,G,G_NMEN,G_NLOEN,R,R_NSMAX) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(D,D_NPTRLS,D_NSTAGTF,PREEL_COMPLEX,F,F_RACTHE,G,G_NMEN,G_NLOEN,R,R_NSMAX) #endif ! ------------------------------------------------------------------ OFFSET_VAR=D%NPTRLS(MYSETW) !* 2. EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. ILOEN_MAX = MAXVAL(G_NLOEN) IF (KUV_EWDER_OFFSET >= 0) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_UV,IOFF_UV_EWDER,RET_REAL,RET_COMPLEX,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_UV,ILOEN_MAX,OFFSET_VAR,G,D,KF_FS,KUV_OFFSET,KUV_EWDER_OFFSET,F,& !$OMP& PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_UV,ILOEN_MAX,OFFSET_VAR,KF_FS,KUV_OFFSET,KUV_EWDER_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IGLG,IOFF_LAT,IOFF_UV,IOFF_UV_EWDER,& !$ACC& RET_REAL,RET_COMPLEX,ZACHTE2,JM,JF,KGL) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,OFFSET_VAR,KF_UV,KUV_EWDER_OFFSET,KUV_OFFSET,KF_FS,ILOEN_MAX) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,2*KF_UV DO JM=0,ILOEN_MAX/2 IGLG = OFFSET_VAR+KGL-1 ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have ! to fill those floor(NLON/2)+1 values. ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. IF (JM <= G_NLOEN(IGLG)/2) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_UV = IOFF_LAT+(KUV_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) IOFF_UV_EWDER = IOFF_LAT+(KUV_EWDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) IF (JM <= G_NMEN(IGLG)) THEN ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) PREEL_COMPLEX(IOFF_UV+2*JM+2) = & & PREEL_COMPLEX(IOFF_UV+2*JM+2) - PREEL_COMPLEX(IOFF_UV_EWDER+2*JM+1)*ZACHTE2*REAL(JM,JPRBT) PREEL_COMPLEX(IOFF_UV+2*JM+1) = & & PREEL_COMPLEX(IOFF_UV+2*JM+1) + PREEL_COMPLEX(IOFF_UV_EWDER+2*JM+2)*ZACHTE2*REAL(JM,JPRBT) ENDIF ENDIF ENDDO ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES IF (KSCALARS_EWDER_OFFSET > 0) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_SCALARS_EWDER,IOFF_SCALARS,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_SCALARS,R,ILOEN_MAX,OFFSET_VAR,KSCALARS_EWDER_OFFSET,KSCALARS_OFFSET,G,D,& !$OMP& KF_FS,F,PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_SCALARS,ILOEN_MAX,OFFSET_VAR,KF_FS,KSCALARS_EWDER_OFFSET,KSCALARS_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IGLG,IOFF_LAT,IOFF_SCALARS_EWDER,& !$ACC& IOFF_SCALARS,ZACHTE2,KGL,JF,JM) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,OFFSET_VAR,KSCALARS_EWDER_OFFSET,KSCALARS_OFFSET,KF_SCALARS,KF_FS,ILOEN_MAX) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,KF_SCALARS DO JM=0,ILOEN_MAX/2 IGLG = OFFSET_VAR+KGL-1 ! FFT transforms NLON real values to floor(NLON/2)+1 complex numbers. Hence we have ! to fill those floor(NLON/2)+1 values. ! Truncation happens starting at G_NMEN+1. Hence, we zero-fill those values. IF (JM <= G_NLOEN(IGLG)/2) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_SCALARS_EWDER = IOFF_LAT+(KSCALARS_EWDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) IOFF_SCALARS = IOFF_LAT+(KSCALARS_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) IF (JM <= G_NMEN(IGLG)) THEN ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) PREEL_COMPLEX(IOFF_SCALARS+2*JM+2) = & & PREEL_COMPLEX(IOFF_SCALARS+2*JM+2) - PREEL_COMPLEX(IOFF_SCALARS_EWDER+2*JM+1)*ZACHTE2*REAL(JM,JPRBT) PREEL_COMPLEX(IOFF_SCALARS+2*JM+1) = & & PREEL_COMPLEX(IOFF_SCALARS+2*JM+1) + PREEL_COMPLEX(IOFF_SCALARS_EWDER+2*JM+2)*ZACHTE2*REAL(JM,JPRBT) ENDIF ENDIF ENDDO ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ !* 1. DIVIDE U V AND N-S DERIVATIVES BY A*COS(THETA) ! ---------------------------------------------- !* 1.1 U AND V. #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_UV,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_UV,R,OFFSET_VAR,G,D,KF_FS,KUV_OFFSET,F,PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_UV,OFFSET_VAR,KF_FS,KUV_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) & !$ACC& PRIVATE(IGLG,IOFF_LAT,IOFF_UV,ZACHTE2,JM,JF,KGL) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,OFFSET_VAR,KF_UV,KUV_OFFSET,KF_FS) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,2*KF_UV DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) IGLG = OFFSET_VAR+KGL-1 IF (JM <= G_NMEN(IGLG)) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_UV = IOFF_LAT+(KUV_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) PREEL_COMPLEX(IOFF_UV+2*JM+1) = & & PREEL_COMPLEX(IOFF_UV+2*JM+1)*ZACHTE2 PREEL_COMPLEX(IOFF_UV+2*JM+2) = & & PREEL_COMPLEX(IOFF_UV+2*JM+2)*ZACHTE2 ENDIF ENDDO ENDDO ENDDO !* 1.2 N-S DERIVATIVES IF (KSCALARS_NSDER_OFFSET >= 0) THEN #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IGLG,IOFF_LAT,IOFF_KSCALARS_NSDER,ZACHTE2) & !$OMP& SHARED(IBEG,IEND,IINC,KF_SCALARS,R,OFFSET_VAR,G,D,KF_FS,KSCALARS_NSDER_OFFSET,F,& !$OMP& PREEL_COMPLEX) & !$OMP& MAP(TO:IBEG,IEND,IINC,KF_SCALARS,OFFSET_VAR,KF_FS,KSCALARS_NSDER_OFFSET) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IGLG,IOFF_LAT,IOFF_KSCALARS_NSDER,ZACHTE2,KGL,JF,JM) & !$ACC& FIRSTPRIVATE(IBEG,IEND,IINC,OFFSET_VAR,KF_SCALARS,KSCALARS_NSDER_OFFSET,KF_FS) & #ifdef _CRAYFTN !! NOTE: These asynchronous kernels are triggering the error: HIPFFT_PARSE_ERROR !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KGL=IBEG,IEND,IINC DO JF=1,KF_SCALARS DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) IGLG = OFFSET_VAR+KGL-1 IF (JM <= G_NMEN(IGLG)) THEN IOFF_LAT = 1_JPIB*KF_FS*D_NSTAGTF(KGL) IOFF_KSCALARS_NSDER = IOFF_LAT+(KSCALARS_NSDER_OFFSET+JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) ZACHTE2 = REAL(F_RACTHE(IGLG),JPRBT) PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+1) = & & PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+1)*ZACHTE2 PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+2) = & & PREEL_COMPLEX(IOFF_KSCALARS_NSDER+2*JM+2)*ZACHTE2 ENDIF ENDDO ENDDO ENDDO ENDIF #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE FSCAD END MODULE FSCAD_MOD ectrans-1.8.0/src/trans/gpu/internal/uvtvdad_mod.F900000775000175000017500000001314615174631767022515 0ustar alastairalastair! (C) Copyright 1991- ECMWF. ! (C) Copyright 1991- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE UVTVDAD_MOD CONTAINS SUBROUTINE UVTVDAD(KF_UV,PU,PV,PVOR,PDIV) !**** *UVTVDAD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX. !** Interface. ! ---------- ! CALL UVTVDAD(KM,KF_UV,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number ! -------------------- KF_UV - number of fields (levels) ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE TPM_FIELDS_GPU, ONLY: FG ! IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV REAL(KIND=JPRBT), INTENT(INOUT) :: PVOR(:,:,:),PDIV(:,:,:) REAL(KIND=JPRBT), INTENT(INOUT) :: PU (:,:,:),PV (:,:,:) INTEGER(KIND=JPIM) :: KM, KMLOC ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IN, IR, J, JN ! LOCAL REAL SCALARS REAL(KIND=JPRBT) :: ZKM,ZJN ! ------------------------------------------------------------------ ASSOCIATE(D_NUMP=>D%NUMP, R_NTMAX=>R%NTMAX, D_MYMS=>D%MYMS, ZEPSNM=>FG%ZEPSNM) !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(D,D_MYMS,D_NUMP,R,R_NTMAX) & !$ACC& PRESENT(FG,ZEPSNM,PU,PV,PVOR,PDIV) ASYNC(1) #endif !* 1.2 COMPUTE VORTICITY AND DIVERGENCE. #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) PRIVATE(IR,II,IN,KM,ZKM,ZJN) & !$OMP& SHARED(D,R,KF_UV,FG,PVOR,PV,PU,PDIV) DEFAULT(NONE) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) PRIVATE(IR,II,IN,KM,ZKM,ZJN) FIRSTPRIVATE(KF_UV) DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=-1,R_NTMAX+1 DO J=1,KF_UV IR = 2*J-1 II = IR+1 KM = D_MYMS(KMLOC) ZKM = REAL(KM,JPRBT) IF(KM /= 0 .AND. JN >= (KM-1)) THEN ! (DO JN=KN,R_NTMAX) IN = R_NTMAX+3-JN ZJN = JN PU(IR,IN,KMLOC) = 0 PU(II,IN,KMLOC) = 0 PV(IR,IN,KMLOC) = 0 PV(II,IN,KMLOC) = 0 IF (2 <= IN .AND. IN <= R_NTMAX + 2) THEN PU(IR,IN,KMLOC) = PU(IR,IN,KMLOC) - (ZJN-1)*ZEPSNM(KMLOC,JN)*PVOR(IR,IN+1,KMLOC) PU(II,IN,KMLOC) = PU(II,IN,KMLOC) - (ZJN-1)*ZEPSNM(KMLOC,JN)*PVOR(II,IN+1,KMLOC) PV(IR,IN,KMLOC) = PV(IR,IN,KMLOC) + (ZJN-1)*ZEPSNM(KMLOC,JN)*PDIV(IR,IN+1,KMLOC) PV(II,IN,KMLOC) = PV(II,IN,KMLOC) + (ZJN-1)*ZEPSNM(KMLOC,JN)*PDIV(II,IN+1,KMLOC) ENDIF IF (3 <= IN .AND. IN <= R_NTMAX + 3) THEN PU(IR,IN,KMLOC) = PU(IR,IN,KMLOC) + ZKM*PDIV(II,IN,KMLOC) PU(II,IN,KMLOC) = PU(II,IN,KMLOC) - ZKM*PDIV(IR,IN,KMLOC) PV(IR,IN,KMLOC) = PV(IR,IN,KMLOC) + ZKM*PVOR(II,IN,KMLOC) PV(II,IN,KMLOC) = PV(II,IN,KMLOC) - ZKM*PVOR(IR,IN,KMLOC) ENDIF IF (4 <= IN .AND. IN <= R_NTMAX + 4) THEN PU(IR,IN,KMLOC) = PU(IR,IN,KMLOC) + (ZJN+2)*ZEPSNM(KMLOC,JN+1)*PVOR(IR,IN-1,KMLOC) PU(II,IN,KMLOC) = PU(II,IN,KMLOC) + (ZJN+2)*ZEPSNM(KMLOC,JN+1)*PVOR(II,IN-1,KMLOC) PV(IR,IN,KMLOC) = PV(IR,IN,KMLOC) - (ZJN+2)*ZEPSNM(KMLOC,JN+1)*PDIV(IR,IN-1,KMLOC) PV(II,IN,KMLOC) = PV(II,IN,KMLOC) - (ZJN+2)*ZEPSNM(KMLOC,JN+1)*PDIV(II,IN-1,KMLOC) ENDIF ELSEIF(KM == 0) THEN ! (DO JN=0,R_NTMAX) IN = R_NTMAX+3-JN ZJN = JN PU(IR,IN,KMLOC) = 0 PU(II,IN,KMLOC) = 0 PV(IR,IN,KMLOC) = 0 PV(II,IN,KMLOC) = 0 IF (2 <= IN .AND. IN <= R_NTMAX + 2) THEN PU(IR,IN,KMLOC) = PU(IR,IN,KMLOC) - (ZJN-1)*ZEPSNM(KMLOC,JN)*PVOR(IR,IN+1,KMLOC) PV(IR,IN,KMLOC) = PV(IR,IN,KMLOC) + (ZJN-1)*ZEPSNM(KMLOC,JN)*PDIV(IR,IN+1,KMLOC) ENDIF IF (4 <= IN .AND. IN <= R_NTMAX + 4) THEN PU(IR,IN,KMLOC) = PU(IR,IN,KMLOC) + (ZJN+2)*ZEPSNM(KMLOC,JN+1)*PVOR(IR,IN-1,KMLOC) PV(IR,IN,KMLOC) = PV(IR,IN,KMLOC) - (ZJN+2)*ZEPSNM(KMLOC,JN+1)*PDIV(IR,IN-1,KMLOC) ENDIF ENDIF ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE UVTVDAD END MODULE UVTVDAD_MOD ectrans-1.8.0/src/trans/gpu/internal/spnsde_mod.F900000775000175000017500000001011215174631767022322 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE SPNSDE_MOD CONTAINS SUBROUTINE SPNSDE(KF_SCALARS,PEPSNM,PF,PNSD) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D !**** *SPNSDE* - Compute North-South derivative in spectral space ! Purpose. ! -------- ! In Laplace space compute the the North-south derivative !** Interface. ! ---------- ! CALL SPNSDE(...) ! Explicit arguments : ! -------------------- ! KM -zonal wavenumber (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PF (NLEI1,2*KF_SCALARS) - input field (input) ! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : YOMLAP ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From SPNSDE in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) :: KM, KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(1:D%NUMP,0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(IN) :: PF(:,:,:) REAL(KIND=JPRB), INTENT(OUT) :: PNSD(:,:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: J, JN, JI, IR, II ASSOCIATE(D_NUMP=>D%NUMP, R_NTMAX=>R%NTMAX, D_MYMS=>D%MYMS) #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:R,R_NTMAX,D,D_MYMS) & !$OMP& MAP(PRESENT,ALLOC:D_NUMP,PEPSNM,PF,PNSD) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT (R,R_NTMAX, D,D_MYMS) & !$ACC& PRESENT (D_NUMP,PEPSNM, PF, PNSD) ASYNC(1) #endif ! ------------------------------------------------------------------ !* 1. COMPUTE NORTH SOUTH DERIVATIVE. ! ------------------------------- !* 1.1 COMPUTE #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(KM,IR,II,JI) MAP(TO:KF_SCALARS) SHARED(D,R,PEPSNM,PF,PNSD,KF_SCALARS) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,IR,II,JI) FIRSTPRIVATE(KF_SCALARS) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=0,R_NTMAX+1 DO J=1,KF_SCALARS IR = 2*J-1 II = IR+1 KM = D_MYMS(KMLOC) IF(KM /= 0 .AND. JN >= KM) THEN ! (DO JN=KN,R_NTMAX+1) JI = R_NTMAX+3-JN PNSD(IR,JI,KMLOC) = -(JN-1)*PEPSNM(KMLOC,JN)*PF(IR,JI+1,KMLOC)+& &(JN+2)*PEPSNM(KMLOC,JN+1)*PF(IR,JI-1,KMLOC) PNSD(II,JI,KMLOC) = -(JN-1)*PEPSNM(KMLOC,JN)*PF(II,JI+1,KMLOC)+& &(JN+2)*PEPSNM(KMLOC,JN+1)*PF(II,JI-1,KMLOC) ELSEIF(KM == 0) THEN ! (DO JN=0,R_NTMAX+1) JI = R_NTMAX+3-JN PNSD(IR,JI,KMLOC) = -(JN-1)*PEPSNM(KMLOC,JN)*PF(IR,JI+1,KMLOC)+& &(JN+2)*PEPSNM(KMLOC,JN+1)*PF(IR,JI-1,KMLOC) PNSD(II,JI,KMLOC) = 0.0_JPRB ENDIF ENDDO ENDDO END DO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE SPNSDE END MODULE SPNSDE_MOD ectrans-1.8.0/src/trans/gpu/internal/inv_trans_ctlad_mod.F900000664000175000017500000002451715174631767024213 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE INV_TRANS_CTLAD_MOD CONTAINS SUBROUTINE INV_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& & KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANS_CTLAD* - Control routine for adjoint of the inverse spectral transform. ! Purpose. ! -------- ! Control routine for the adjoint of the inverse spectral transform !** Interface. ! ---------- ! CALL INV_TRANS_CTLAD(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! 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. ! PGP(:,:,:) - gridpoint fields (output) ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! vorticity : KF_UV_G fields ! divergence : KF_UV_G fields ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! N-S derivative of scalar fields : KF_SCALARS_G fields ! E-W derivative of u : KF_UV_G fields ! E-W derivative of v : KF_UV_G fields ! E-W derivative of scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPRD USE TPM_GEN, ONLY: NPROMATR USE TPM_TRANS, ONLY: LDIVGP, LSCDERS, LUVDER, LVORGP, GROWING_ALLOCATION USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, MAKE_BUFFERED_ALLOCATOR, INSTANTIATE_ALLOCATOR USE TRMTOLAD_MOD, ONLY: PREPARE_TRMTOLAD, TRMTOLAD_HANDLE, TRMTOLAD USE LTINVAD_MOD, ONLY: PREPARE_LTINVAD, LTINVAD_HANDLE, LTINVAD USE TRMTOLAD_PACK_UNPACK, ONLY: TRMTOLAD_PACK_HANDLE, TRMTOLAD_UNPACK_HANDLE, & & PREPARE_TRMTOLAD_PACK, PREPARE_TRMTOLAD_UNPACK, TRMTOLAD_PACK, & & TRMTOLAD_UNPACK USE FSCAD_MOD, ONLY: FSCAD USE FTDIR_MOD, ONLY: FTDIR_HANDLE, PREPARE_FTDIR, FTDIR USE TRGTOL_MOD, ONLY: TRGTOL_HANDLE, PREPARE_TRGTOL, TRGTOL IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS 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(:,:) 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(:) 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(:,:,:) ! Local variables REAL(KIND=JPRB), POINTER :: FOUBUF(:), FOUBUF_IN(:) REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:), PREEL_COMPLEX(:) REAL(KIND=JPRBT), POINTER :: ZOUTS(:), ZOUTA(:) REAL(KIND=JPRD), POINTER :: ZOUTS0(:), ZOUTA0(:) INTEGER(KIND=JPIM) :: KUV_OFFSET, KSCALARS_OFFSET, KSCALARS_NSDER_OFFSET, & & KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET INTEGER(KIND=JPIM) :: IF_LEG, IF_FOURIER INTEGER(KIND=JPIM) :: IFIRST TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR TYPE(LTINVAD_HANDLE) :: HLTINVAD TYPE(TRMTOLAD_PACK_HANDLE) :: HTRMTOL_PACK TYPE(TRMTOLAD_HANDLE) :: HTRMTOL TYPE(TRMTOLAD_UNPACK_HANDLE) :: HTRMTOL_UNPACK TYPE(FTDIR_HANDLE) :: HFTDIR TYPE(TRGTOL_HANDLE) :: HTRGTOL ! ------------------------------------------------------------------ IF (NPROMATR > 0) THEN CALL ABORT_TRANS("NPROMATR > 0 not supported for GPU") ENDIF ! Compute Vertical domain decomposition ! Initialize potentially unset offsets KSCALARS_NSDER_OFFSET = -1 KUV_EWDER_OFFSET = -1 KSCALARS_EWDER_OFFSET = -1 ! (note in ltinv we will initially start with a slightly different domain decomposition ! which always has vorticity and divergence because this is the actual input) IFIRST = 0 IF (LVORGP) IFIRST = IFIRST + KF_UV ! Vorticity IF (LDIVGP) IFIRST = IFIRST + KF_UV ! Divergence KUV_OFFSET = IFIRST IFIRST = IFIRST + KF_UV ! U IFIRST = IFIRST + KF_UV ! V KSCALARS_OFFSET = IFIRST IFIRST = IFIRST + KF_SCALARS ! Scalars IF (LSCDERS) THEN KSCALARS_NSDER_OFFSET = IFIRST IFIRST = IFIRST + KF_SCALARS ! Scalars NS Derivatives ENDIF ! the rest of fields is being computed in fourier space, namely in FSC IF_LEG = IFIRST IF (LUVDER) THEN KUV_EWDER_OFFSET = IFIRST IFIRST = IFIRST+2*KF_UV ! U and V derivatives ENDIF IF (LSCDERS) THEN KSCALARS_EWDER_OFFSET = IFIRST IFIRST = IFIRST + KF_SCALARS ! Scalars EW Derivatives ENDIF IF_FOURIER = IFIRST IF (IF_FOURIER /= KF_FS) CALL ABORT_TRANS('Size mismatch: Wrong computation KF_FS') ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() HTRGTOL = PREPARE_TRGTOL(ALLOCATOR,KF_GP,IF_FOURIER) IF (KF_FS > 0) THEN HFTDIR = PREPARE_FTDIR(ALLOCATOR,IF_FOURIER) HTRMTOL_UNPACK = PREPARE_TRMTOLAD_UNPACK(ALLOCATOR,IF_LEG) HTRMTOL = PREPARE_TRMTOLAD(ALLOCATOR,IF_LEG) HTRMTOL_PACK = PREPARE_TRMTOLAD_PACK(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) HLTINVAD = PREPARE_LTINVAD(ALLOCATOR,KF_UV,KF_SCALARS,LVORGP,LDIVGP,LSCDERS) ENDIF CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) ! Adjoint of transposition into grid-point space CALL GSTATS(157,0) CALL TRGTOL(ALLOCATOR,HTRGTOL,PREEL_REAL,IF_FOURIER,KF_GP,KF_UV_G,KF_SCALARS_G,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) CALL GSTATS(157,1) IF (KF_FS > 0) THEN CALL GSTATS(107,0) ! Fourier transformations CALL FTDIR(ALLOCATOR,HFTDIR,PREEL_REAL,PREEL_COMPLEX,IF_FOURIER) ! compute NS derivatives CALL FSCAD(PREEL_COMPLEX, IF_FOURIER, KF_UV, KF_SCALARS, KUV_OFFSET, KSCALARS_OFFSET, & & KSCALARS_NSDER_OFFSET, KUV_EWDER_OFFSET, KSCALARS_EWDER_OFFSET) CALL GSTATS(107,1) ! Packing into send buffer, to fourier space and unpack CALL GSTATS(152,0) CALL TRMTOLAD_UNPACK(ALLOCATOR,HTRMTOL_UNPACK,FOUBUF,PREEL_COMPLEX,IF_LEG,IF_FOURIER) CALL TRMTOLAD(ALLOCATOR,HTRMTOL,FOUBUF_IN,FOUBUF,IF_LEG) CALL TRMTOLAD_PACK(ALLOCATOR,HTRMTOL_PACK,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,FOUBUF_IN,IF_LEG) CALL GSTATS(152,1) ! Legendre transformations CALL GSTATS(102,0) CALL LTINVAD(ALLOCATOR,HLTINVAD,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2, & & ZOUTS,ZOUTA,ZOUTS0,ZOUTA0) CALL GSTATS(102,1) ENDIF END SUBROUTINE INV_TRANS_CTLAD END MODULE INV_TRANS_CTLAD_MOD ectrans-1.8.0/src/trans/gpu/internal/trltomad_pack_unpack.F900000775000175000017500000002472115174631767024367 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRLTOMAD_PACK_UNPACK USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE USE PARKIND_ECTRANS, ONLY: JPIM IMPLICIT NONE PRIVATE PUBLIC :: TRLTOMAD_PACK_HANDLE, PREPARE_TRLTOMAD_PACK, TRLTOMAD_PACK PUBLIC :: TRLTOMAD_UNPACK_HANDLE, PREPARE_TRLTOMAD_UNPACK, TRLTOMAD_UNPACK TYPE TRLTOMAD_PACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HREEL_COMPLEX END TYPE TYPE TRLTOMAD_UNPACK_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPFBUF END TYPE INTEGER(KIND=JPIM) :: A = 8 !Alignment CONTAINS FUNCTION PREPARE_TRLTOMAD_PACK(ALLOCATOR, KF_FS) RESULT(HTRLTOM_PACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE ISO_C_BINDING, ONLY: C_SIZEOF USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(TRLTOMAD_PACK_HANDLE) :: HTRLTOM_PACK REAL(KIND=JPRBT) :: DUMMY HTRLTOM_PACK%HREEL_COMPLEX = RESERVE(ALLOCATOR, 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(DUMMY), & & "HTRLTOMAD_PACK%HREEL_COMPLEX") END FUNCTION PREPARE_TRLTOMAD_PACK SUBROUTINE TRLTOMAD_PACK(ALLOCATOR,HTRLTOM_PACK,PREEL_COMPLEX,FOUBUF_IN,KF_FS) !**** *TRLTOMAD_PACK* - Copy fourier data from local array to buffer ! Purpose. ! -------- ! Routine for copying fourier data from local array to buffer !** Interface. ! ---------- ! CALL TRLTOM_PACK(...) ! Explicit arguments : PREEL - local fourier/GP array ! -------------------- KF_FS - number of fields ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! ------------------------------------------------------------------ USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D, MYSETW USE TPM_GEOMETRY, ONLY: G USE TPM_DIM, ONLY: R USE ISO_C_BINDING, ONLY: C_SIZEOF ! IMPLICIT NONE REAL(KIND=JPRBT), POINTER, INTENT(OUT) :: PREEL_COMPLEX(:) REAL(KIND=JPRBT), INTENT(IN) :: FOUBUF_IN(:) INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRLTOMAD_PACK_HANDLE), INTENT(IN) :: HTRLTOM_PACK INTEGER(KIND=JPIM) :: JM,JF,IGLG,OFFSET_VAR,KGL,J,N INTEGER(KIND=JPIB) :: IOFF_LAT,ISTA REAL(KIND=JPRBT) :: SCAL ASSOCIATE(D_NSTAGTF=>D%NSTAGTF, D_NPNTGTB0=>D%NPNTGTB0, D_NPTRLS=>D%NPTRLS, & & D_NDGL_FS=>D%NDGL_FS, G_NMEN=>G%NMEN, G_NLOEN=>G%NLOEN, R_NSMAX=>R%NSMAX) CALL ASSIGN_PTR(PREEL_COMPLEX, GET_ALLOCATION(ALLOCATOR, HTRLTOM_PACK%HREEL_COMPLEX),& & 1_JPIB, 1_JPIB*KF_FS*D%NLENGTF*C_SIZEOF(PREEL_COMPLEX(1))) N = 1_JPIB*KF_FS*D%NLENGTF #ifdef ACCGPU !$ACC DATA PRESENT(PREEL_COMPLEX) !$ACC PARALLEL LOOP FIRSTPRIVATE(N) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PREEL_COMPLEX) !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) SHARED(N,PREEL_COMPLEX) #endif DO J=1,N PREEL_COMPLEX(J) = 0 ENDDO #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:G,G_NMEN,D,D_NPNTGTB0,FOUBUF_IN,PREEL_COMPLEX,D_NSTAGTF,& !$OMP& D_NDGL_FS,G_NLOEN,R,R_NSMAX) #endif #ifdef ACCGPU !$ACC DATA PRESENT(G,G_NMEN,D,D_NPNTGTB0,FOUBUF_IN,PREEL_COMPLEX,D_NSTAGTF,D_NDGL_FS,G_NLOEN, R,R_NSMAX) ASYNC(1) #endif ! scale results and move into next transformation buffer OFFSET_VAR=D_NPTRLS(MYSETW) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) PRIVATE(IGLG,IOFF_LAT,ISTA,SCAL) & !$OMP& SHARED(D,R,KF_FS,OFFSET_VAR,G,& !$OMP& PREEL_COMPLEX,FOUBUF_IN) MAP(TO:KF_FS,OFFSET_VAR) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP PRIVATE(IGLG,IOFF_LAT,ISTA,SCAL) FIRSTPRIVATE(KF_FS,OFFSET_VAR) & !$ACC& TILE(32,16,1) DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KGL=1,D_NDGL_FS DO JM=0,R_NSMAX !(note that R_NSMAX <= G_NMEN(IGLG) for all IGLG) DO JF=1,KF_FS IGLG = OFFSET_VAR+KGL-1 IF (JM <= G_NMEN(IGLG)) THEN IOFF_LAT = KF_FS*D_NSTAGTF(KGL)+(JF-1)*(D_NSTAGTF(KGL+1)-D_NSTAGTF(KGL)) SCAL = 1._JPRBT/REAL(G_NLOEN(IGLG),JPRBT) ISTA = 2_JPIB*D_NPNTGTB0(JM,KGL)*KF_FS PREEL_COMPLEX(IOFF_LAT+2*JM+1) = SCAL * FOUBUF_IN(ISTA+2*JF-1) PREEL_COMPLEX(IOFF_LAT+2*JM+2) = SCAL * FOUBUF_IN(ISTA+2*JF ) ENDIF ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA !$ACC WAIT(1) #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif END ASSOCIATE END SUBROUTINE TRLTOMAD_PACK FUNCTION PREPARE_TRLTOMAD_UNPACK(ALLOCATOR, KF_FS) RESULT(HTRLTOM_UNPACK) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE LEDIR_MOD, ONLY: LEDIR_STRIDES USE ISO_C_BINDING, ONLY: C_SIZEOF USE TPM_DISTR, ONLY: D IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(TRLTOMAD_UNPACK_HANDLE) :: HTRLTOM_UNPACK INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE INTEGER(KIND=JPIB) :: ISIZE REAL(KIND=JPRBT) :: DUMMY CALL LEDIR_STRIDES(KF_FS,IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) HTRLTOM_UNPACK%HPFBUF = RESERVE(ALLOCATOR, 2_JPIB*D%NLENGT1B*KF_FS*C_SIZEOF(DUMMY), "HTRLTOM_UNPACK%HPFBUF") END FUNCTION PREPARE_TRLTOMAD_UNPACK SUBROUTINE TRLTOMAD_UNPACK(ALLOCATOR,HTRLTOM_UNPACK,FOUBUF,ZINPS,ZINPA,ZINPS0,ZINPA0,KF_FS,KF_UV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_FIELDS, ONLY: F USE TPM_DISTR, ONLY: D USE LEDIR_MOD, ONLY: LEDIR_STRIDES USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE REAL(KIND=JPRBT), POINTER, INTENT(OUT) :: FOUBUF(:) REAL(KIND=JPRBT), INTENT(IN) :: ZINPS(:), ZINPA(:) REAL(KIND=JPRD), INTENT(IN) :: ZINPS0(:), ZINPA0(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS, KF_UV TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRLTOMAD_UNPACK_HANDLE), INTENT(IN) :: HTRLTOM_UNPACK REAL(KIND=JPRBT), POINTER :: PREEL_COMPLEX(:) INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE INTEGER(KIND=JPIB) :: JF, OFFSET1, OFFSET2 INTEGER(KIND=JPIM) :: KM, ISL, IGLS, JGL, KMLOC REAL(KIND=JPRBT) :: PAIA, PAIS ASSOCIATE(D_NUMP=>D%NUMP, R_NDGNH=>R%NDGNH, R_NDGL=>R%NDGL, F_RW=>F%RW, F_RACTHE=>F%RACTHE, & & D_MYMS=>D%MYMS, D_NPNTGTB1=>D%NPNTGTB1, D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1, & & G_NDGLU=>G%NDGLU) CALL LEDIR_STRIDES(KF_FS,IIN_STRIDES0=IIN_STRIDES0,IIN_SIZE=IIN_SIZE,& IIN0_STRIDES0=IIN0_STRIDES0,IIN0_SIZE=IIN0_SIZE) CALL ASSIGN_PTR(FOUBUF, GET_ALLOCATION(ALLOCATOR, HTRLTOM_UNPACK%HPFBUF),& & 1_JPIB, 2_JPIB*D%NLENGT1B*KF_FS*C_SIZEOF(FOUBUF(1))) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:ZINPS,ZINPA,ZINPS0,ZINPA0) & !$OMP& MAP(PRESENT,ALLOC:F,F_RW,F_RACTHE) & !$OMP& MAP(PRESENT,ALLOC:D,D_MYMS,D_NUMP,R,R_NDGNH,R_NDGL,G,G_NDGLU) & !$OMP& MAP(PRESENT,ALLOC:D_NPNTGTB1,D_OFFSETS_GEMM1,FOUBUF) !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,PAIA,PAIS) & !$OMP& SHARED(D,R,KF_FS,G,FOUBUF,F,& !$OMP& IIN_STRIDES0,ZINPA,ZINPS,IIN0_STRIDES0,ZINPA0,ZINPS0,KF_UV) & !$OMP& MAP(TO:KF_FS,KF_UV,IIN_STRIDES0,IIN0_STRIDES0) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(ZINPS,ZINPA,ZINPS0,ZINPA0) & !$ACC& PRESENT(F,F_RW,F_RACTHE) & !$ACC& PRESENT(D,D_MYMS,D_NUMP,R,R_NDGNH,R_NDGL,G,G_NDGLU) & !$ACC& PRESENT(D_NPNTGTB1,D_OFFSETS_GEMM1,FOUBUF) !$ACC PARALLEL LOOP DEFAULT(NONE) COLLAPSE(3) PRIVATE(KM,ISL,IGLS,OFFSET1,OFFSET2,JGL,PAIA,PAIS) & !$ACC& FIRSTPRIVATE(KF_FS,KF_UV,IIN_STRIDES0,IIN0_STRIDES0) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JGL=1,R_NDGNH DO JF=1,KF_FS*2 KM = D_MYMS(KMLOC) ISL = R_NDGNH-G_NDGLU(KM)+1 IF (JGL >= ISL) THEN !(DO JGL=ISL,R_NDGNH) IGLS = R_NDGL+1-JGL OFFSET1 = 2_JPIB*D_NPNTGTB1(KMLOC,JGL )*KF_FS OFFSET2 = 2_JPIB*D_NPNTGTB1(KMLOC,IGLS)*KF_FS PAIA = 0 PAIS = 0 IF (KM /= 0) THEN PAIA=REAL(F_RW(JGL),JPRBT)*ZINPA(JF+(JGL-ISL)*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC)) PAIS=REAL(F_RW(JGL),JPRBT)*ZINPS(JF+(JGL-ISL)*IIN_STRIDES0+IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC)) ELSEIF (MOD(JF-1,2) == 0) THEN ! every other field is sufficient because Im(KM=0) == 0 PAIA=REAL(F_RW(JGL),JPRBT)*ZINPA0((JF-1)/2+1+(JGL-1)*IIN0_STRIDES0) PAIS=REAL(F_RW(JGL),JPRBT)*ZINPS0((JF-1)/2+1+(JGL-1)*IIN0_STRIDES0) ENDIF IF (JF <= 4*KF_UV) THEN ! Multiply in case of velocity PAIA = PAIA*REAL(F_RACTHE(JGL),JPRBT) PAIS = PAIS*REAL(F_RACTHE(JGL),JPRBT) ENDIF FOUBUF(OFFSET1+JF) = PAIA+PAIS FOUBUF(OFFSET2+JF) = -PAIA+PAIS ENDIF ENDDO ENDDO END DO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif END ASSOCIATE END SUBROUTINE TRLTOMAD_UNPACK END MODULE TRLTOMAD_PACK_UNPACK ectrans-1.8.0/src/trans/gpu/internal/updsp_mod.F900000775000175000017500000001076115174631767022173 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE UPDSP_MOD CONTAINS SUBROUTINE UPDSP(KF_UV,KF_SCALARS,POA1, & & PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) !**** *UPDSP* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update the spectral arrays for a fixed zonal wave-number ! from values in POA1 and POA2. !** Interface. ! ---------- ! CALL UPDSP(...) ! Explicit arguments : ! -------------------- ! KM - zonal wave-number ! POA1 - spectral fields for zonal wavenumber KM (basic var.) ! PSPSCALAR - spectral scalar variables ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Externals. UPDSPB - basic transfer routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 94-08-02 R. El Khatib - interface to UPDSPB ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM ,JPRB, JPRBT USE TPM_TRANS, ONLY: NF_SC2, NF_SC3A, NF_SC3B USE TPM_DISTR, ONLY: D USE UPDSPB_MOD, ONLY: UPDSPB IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS REAL(KIND=JPRBT) , INTENT(IN) :: POA1(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IST ,IEND,IDIM1,IDIM3,J3 ! ------------------------------------------------------------------ !* 1. UPDATE FIELDS ! ------------- !* 1.1 VORTICITY AND DIVERGENCE. #ifdef ACCGPU !$ACC DATA PRESENT(PSPSCALAR) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSCALAR)) !$ACC DATA PRESENT(PSPSC2) IF(NF_SC2 > 0) !$ACC DATA PRESENT(PSPSC3A) IF(NF_SC3A > 0) !$ACC DATA PRESENT(PSPSC3B) IF(NF_SC3B > 0) #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSCALAR) IF(KF_SCALARS > 0 .AND. PRESENT(PSPSCALAR)) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSC2) IF(NF_SC2 > 0) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSC3A) IF(NF_SC3A > 0) !$OMP TARGET DATA MAP(PRESENT,ALLOC:PSPSC3B) IF(NF_SC3B > 0) #endif IST = 1 IST = IST+4*KF_UV !* 1.2 SCALARS IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IEND = IST+2*KF_SCALARS-1 CALL UPDSPB(KF_SCALARS,POA1(IST:IEND,:,:),PSPSCALAR,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IDIM1 = NF_SC2 IEND = IST+2*IDIM1-1 CALL UPDSPB(IDIM1,POA1(IST:IEND,:,:),PSPSC2) IST=IST+2*IDIM1 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPB(IDIM1,POA1(IST:IEND,:,:),PSPSC3A(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPB(IDIM1,POA1(IST:IEND,:,:),PSPSC3B(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF ENDIF ENDIF #ifdef OMPGPU !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA !$ACC END DATA !$ACC END DATA !$ACC END DATA #endif ! ------------------------------------------------------------------ END SUBROUTINE UPDSP END MODULE UPDSP_MOD ectrans-1.8.0/src/trans/gpu/internal/set_resol_mod.F900000775000175000017500000000414015174631767023031 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE SET_RESOL_MOD CONTAINS SUBROUTINE SET_RESOL(KRESOL,LDSETUP) USE PARKIND1, ONLY: JPIM USE TPM_GEN, ONLY: NOUT, MSETUP0, NCUR_RESOL, NMAX_RESOL, LENABLED USE TPM_DIM, ONLY: R, DIM_RESOL USE TPM_DISTR, ONLY: D, DISTR_RESOL USE TPM_GEOMETRY, ONLY: G, GEOM_RESOL USE TPM_FIELDS, ONLY: F, FIELDS_RESOL USE TPM_FIELDS_GPU, ONLY: FG, FIELDS_GPU_RESOL USE TPM_FLT, ONLY: S, FLT_RESOL USE TPM_CTL, ONLY: C, CTL_RESOL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL LOGICAL ,OPTIONAL, INTENT(IN) :: LDSETUP ! Local variables INTEGER(KIND=JPIM) :: IRESOL LOGICAL :: LLSETUP ! ------------------------------------------------------------------ IF(MSETUP0 == 0) CALL ABORT_TRANS('SET_RESOL:TRANS NOT SETUP') LLSETUP = .FALSE. IF(PRESENT(LDSETUP)) LLSETUP = LDSETUP IRESOL = 1 IF(PRESENT(KRESOL)) THEN IRESOL = KRESOL IF(IRESOL < 1 .OR. IRESOL > NMAX_RESOL) THEN WRITE(NOUT,*)'SET_RESOL: UNKNOWN RESOLUTION ',IRESOL,NMAX_RESOL CALL ABORT_TRANS('SET_RESOL:IRESOL < 1 .OR. KRESOL > NMAX_RESOL') ENDIF IF(.NOT.LLSETUP) THEN IF(.NOT.LENABLED(IRESOL)) THEN WRITE(NOUT,*)'SET_RESOL: UNKNOWN RESOLUTION ',IRESOL,LENABLED CALL ABORT_TRANS('SET_RESOL:IRESOL NOT ENABLED') ENDIF ENDIF ENDIF IF(IRESOL /= NCUR_RESOL) THEN NCUR_RESOL = IRESOL R => DIM_RESOL(NCUR_RESOL) F => FIELDS_RESOL(NCUR_RESOL) FG => FIELDS_GPU_RESOL(NCUR_RESOL) G => GEOM_RESOL(NCUR_RESOL) D => DISTR_RESOL(NCUR_RESOL) S => FLT_RESOL(NCUR_RESOL) C => CTL_RESOL(NCUR_RESOL) ENDIF END SUBROUTINE SET_RESOL END MODULE SET_RESOL_MOD ectrans-1.8.0/src/trans/gpu/internal/tpm_stats.F900000664000175000017500000000324015174631767022206 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TPM_STATS IMPLICIT NONE CHARACTER(LEN=32) :: DESCRIPTIONS(100) CONTAINS SUBROUTINE GSTATS_LABEL_NVTX(KNUM,CTYPE,CDESC) USE EC_PARKIND, ONLY: JPIM IMPLICIT NONE INTEGER(KIND=JPIM) :: KNUM CHARACTER(*), INTENT(IN) :: CDESC CHARACTER(*), INTENT(IN) :: CTYPE IF (KNUM >= 400 .AND. KNUM < 500) THEN DESCRIPTIONS(KNUM-400+1) = CDESC ENDIF CALL GSTATS_LABEL(KNUM,CTYPE,CDESC) END SUBROUTINE SUBROUTINE GSTATS_NVTX(KNUM,KSWITCH) USE EC_PARKIND, ONLY: JPIM #if defined(__NVCOMPILER) USE NVTX, ONLY: NVTXSTARTRANGE, NVTXENDRANGE #endif IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KNUM INTEGER(KIND=JPIM),INTENT(IN) :: KSWITCH INTEGER(KIND=JPIM) :: ICOLOR #if defined(__NVCOMPILER) IF (KNUM >= 400 .AND. KNUM < 500) THEN IF (KSWITCH == 0) THEN ICOLOR=0 IF (KNUM>=430) ICOLOR=10 !LB markers IF (KNUM==410) ICOLOR=13 !DIR COMPLETE IF (KNUM==420) ICOLOR=14 !INV COMPLETE IF (ICOLOR /= 0) THEN CALL NVTXSTARTRANGE(DESCRIPTIONS(KNUM-400+1),ICOLOR) ELSE CALL NVTXSTARTRANGE(DESCRIPTIONS(KNUM-400+1)) ENDIF ELSEIF (KSWITCH == 1) THEN CALL NVTXENDRANGE() ENDIF ENDIF #endif CALL GSTATS(KNUM,KSWITCH) END SUBROUTINE GSTATS_NVTX END MODULE TPM_STATS ectrans-1.8.0/src/trans/gpu/internal/dist_grid_32_ctl_mod.F900000775000175000017500000001653615174631767024164 0ustar alastairalastair! (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. ! MODULE DIST_GRID_32_CTL_MOD CONTAINS SUBROUTINE DIST_GRID_32_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP) !**** *DIST_GRID_32_CTL* - Distributing global gridpoint array to processors ! Purpose. ! -------- ! Routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID_32_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint output ! KFROM(:) - Processor responsible for distributing each field ! PGP(:,:,:) - Local spectral array ! Externals. SET2PE - compute "A and B" set from PE ! ---------- MPL.. - message passing routines ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRM USE MPL_MODULE, ONLY: MPL_RECV, JP_BLOCKING_STANDARD, MPL_SEND, JP_NON_BLOCKING_STANDARD, & & MPL_WAIT, MPL_BARRIER USE TPM_DISTR, ONLY: D, NPROC, MYPROC, MTAGDISTGP, NPRCIDS USE TPM_GEOMETRY, ONLY: G USE SET2PE_MOD, ONLY: SET2PE USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE EQ_REGIONS_MOD, ONLY: N_REGIONS_NS, N_REGIONS IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) REAL(KIND=JPRM) , INTENT(OUT) :: PGP(:,:,:) ! Declaration of local variables REAL(KIND=JPRM) :: ZDUM(D%NGPTOTMX) REAL(KIND=JPRM),ALLOCATABLE :: ZBUF(:,:,:),ZRCV2(:,:) REAL(KIND=JPRM) :: ZRCV(D%NGPTOTMX,KFDISTG) INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF,ILENR INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG) INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD,IFLDSFROM(NPROC) LOGICAL :: LLSAME ! ------------------------------------------------------------------ ! Copy for single PE IF(NPROC == 1) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,JFLD,IBL) = PGPG(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ELSEIF(KFDISTG>0) THEN ! test if values in KFROM are all the same LLSAME=.TRUE. IFROM=KFROM(1) DO JFLD=2,KFDISTG IF(KFROM(JFLD) /= IFROM) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO IMYFIELDS = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO CALL GSTATS(1663,0) IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILOFF,JGL,JLON) DO JFLD=1,IMYFIELDS DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(ISND,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN(ISND,JFLD) = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = & & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) ENDDO ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1663,1) ! Message passing CALL GSTATS_BARRIER(791) CALL GSTATS(811,0) ! Send IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN ITAG = MTAGDISTGP DO JROC=1,NPROC CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),& &CDSTRING='DIST_GRID_32_CTL') ENDDO ENDIF ELSE IF(IMYFIELDS > 0) THEN ITAG = MTAGDISTGP DO JROC=1,NPROC CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),& &CDSTRING='DIST_GRID_32_CTL') ENDDO ENDIF ENDIF ! Receive IF( LLSAME )THEN IRCV = KFROM(1) ITAG = MTAGDISTGP CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_32_CTL:') IF( ILENR /= D%NGPTOTMX*KFDISTG )THEN CALL ABORT_TRANS(' DIST_GRID_32_CTL: INVALID RECEIVE MESSAGE LENGTH 1') ENDIF ELSE IFLDSFROM(:)=0 DO JFLD=1,KFDISTG IFLDSFROM(KFROM(JFLD)) = IFLDSFROM(KFROM(JFLD))+1 ENDDO ITAG = MTAGDISTGP DO JROC=1,NPROC IF(IFLDSFROM(JROC) > 0 ) THEN IRCV = JROC ALLOCATE(ZRCV2(D%NGPTOTMX,IFLDSFROM(JROC))) CALL MPL_RECV(ZRCV2,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_32_CTL:') IF( ILENR /= D%NGPTOTMX*IFLDSFROM(JROC) )THEN CALL ABORT_TRANS(' DIST_GRID_32_CTL: INVALID RECEIVE MESSAGE LENGTH 2') ENDIF IFLD = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == JROC) THEN IFLD = IFLD+1 ZRCV(1:D%NGPTOT,JFLD) = ZRCV2(1:D%NGPTOT,IFLD) ENDIF ENDDO DEALLOCATE(ZRCV2) ENDIF ENDDO ENDIF ! Wait for send to complete IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), & & CDSTRING='DIST_GRID_32_CTL: WAIT 1') ENDIF ELSEIF(IMYFIELDS > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), & & CDSTRING='DIST_GRID_32_CTL: WAIT 2') ENDIF CALL GSTATS(811,1) CALL GSTATS_BARRIER2(791) CALL GSTATS(1663,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,JFLD,IBL) = ZRCV(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1663,1) !Synchronize processors CALL GSTATS(786,0) CALL MPL_BARRIER(CDSTRING='DIST_GRID_32_CTL:') CALL GSTATS(786,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID_32_CTL END MODULE DIST_GRID_32_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/vdtuv_mod.F900000775000175000017500000001261015174631767022203 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE VDTUV_MOD CONTAINS SUBROUTINE VDTUV(KFIELD,PEPSNM,PVOR,PDIV,PU,PV) USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT USE TPM_DIM, ONLY: R USE TPM_FIELDS, ONLY: F USE TPM_DISTR, ONLY: D !**** *VDTUV* - Compute U,V in spectral space ! Purpose. ! -------- ! In Laplace space compute the the winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL VDTUV(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PVOR(NLEI1,2*KFIELD) - vorticity (input) ! PDIV(NLEI1,2*KFIELD) - divergence (input) ! PU(NLEI1,2*KFIELD) - u wind (output) ! PV(NLEI1,2*KFIELD) - v wind (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUV in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) :: KM, KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD REAL(KIND=JPRBT), INTENT(IN) :: PEPSNM(1:D%NUMP,0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(INOUT) :: PVOR(:,:,:),PDIV(:,:,:) REAL(KIND=JPRB), INTENT(OUT) :: PU (:,:,:),PV (:,:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IR, J, JN, JI ! LOCAL REAL SCALARS REAL(KIND=JPRBT) :: ZKM ASSOCIATE(D_NUMP=>D%NUMP, D_MYMS=>D%MYMS, R_NTMAX=>R%NTMAX, F_RLAPIN=>F%RLAPIN) #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(R,R_NTMAX,D,D_MYMS,D_NUMP,F,F_RLAPIN) & !$ACC& PRESENT(PEPSNM, PVOR, PDIV) & !$ACC& PRESENT(PU, PV) #endif #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:R,R_NTMAX,D,D_MYMS,D_NUMP,F,F_RLAPIN) & !$OMP& MAP(PRESENT,ALLOC:PEPSNM, PVOR, PDIV) & !$OMP& MAP(PRESENT,ALLOC:PU, PV) #endif ! ------------------------------------------------------------------ !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) DEFAULT(NONE) & !$OMP& PRIVATE(IR,II,KM,ZKM,JI) SHARED(D,R,F,PEPSNM,PVOR,PDIV,PU,PV,KFIELD) & !$OMP& MAP(TO:KFIELD) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(3) DEFAULT(NONE) PRIVATE(IR,II,KM,ZKM,JI) FIRSTPRIVATE(KFIELD,KMLOC) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JN=0,R_NTMAX+1 DO J=1,KFIELD IR = 2*J-1 II = IR+1 KM = D_MYMS(KMLOC) ZKM = REAL(KM,JPRBT) IF(KM /= 0 .AND. JN >= KM) THEN ! (DO JN=KN,R_NTMAX) JI = R_NTMAX+3-JN PU(IR,JI,KMLOC) = -ZKM*F_RLAPIN(JN)*PDIV(II,JI,KMLOC)+& &(JN-1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN-1)*PVOR(IR,JI+1,KMLOC)-& &(JN+2)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN+1)*PVOR(IR,JI-1,KMLOC) PU(II,JI,KMLOC) = +ZKM*F_RLAPIN(JN)*PDIV(IR,JI,KMLOC)+& &(JN-1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN-1)*PVOR(II,JI+1,KMLOC)-& &(JN+2)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN+1)*PVOR(II,JI-1,KMLOC) PV(IR,JI,KMLOC) = -ZKM*F_RLAPIN(JN)*PVOR(II,JI,KMLOC)-& &(JN-1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN-1)*PDIV(IR,JI+1,KMLOC)+& &(JN+2)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN+1)*PDIV(IR,JI-1,KMLOC) PV(II,JI,KMLOC) = +ZKM*F_RLAPIN(JN)*PVOR(IR,JI,KMLOC)-& &(JN-1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN-1)*PDIV(II,JI+1,KMLOC)+& &(JN+2)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN+1)*PDIV(II,JI-1,KMLOC) ELSEIF(KM == 0) THEN ! (DO JN=0,R_NTMAX) JI = R_NTMAX+3-JN PU(IR,JI,KMLOC) = +& &(JN-1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN-1)*PVOR(IR,JI+1,KMLOC)-& &(JN+2)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN+1)*PVOR(IR,JI-1,KMLOC) PV(IR,JI,KMLOC) = -& &(JN-1)*PEPSNM(KMLOC,JN)*F_RLAPIN(JN-1)*PDIV(IR,JI+1,KMLOC)+& &(JN+2)*PEPSNM(KMLOC,JN+1)*F_RLAPIN(JN+1)*PDIV(IR,JI-1,KMLOC) ENDIF ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE VDTUV END MODULE VDTUV_MOD ectrans-1.8.0/src/trans/gpu/internal/ledir_mod.F900000775000175000017500000003170615174631767022141 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) #if defined CUDAGPU #define ACC_GET_HIP_STREAM ACC_GET_CUDA_STREAM #define OPENACC_LIB OPENACC #endif ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE LEDIR_MOD USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPRD, JPIB USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR IMPLICIT NONE PRIVATE PUBLIC :: LEDIR_STRIDES, LEDIR INTEGER(KIND=JPIM) :: A = 8 !Alignment CONTAINS SUBROUTINE LEDIR_STRIDES(KF_FS,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), OPTIONAL :: IOUT_STRIDES0 INTEGER(KIND=JPIB), OPTIONAL :: IOUT_SIZE INTEGER(KIND=JPIM), OPTIONAL :: IIN_STRIDES0 INTEGER(KIND=JPIB), OPTIONAL :: IIN_SIZE INTEGER(KIND=JPIM), OPTIONAL :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM), OPTIONAL :: IIN0_STRIDES0, IIN0_SIZE ASSOCIATE(D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1, D_OFFSETS_GEMM2=>D%OFFSETS_GEMM2) IF (PRESENT(IOUT_STRIDES0)) & IOUT_STRIDES0 = ALIGN(2*KF_FS,A) IF (PRESENT(IOUT_SIZE)) & IOUT_SIZE = IOUT_STRIDES0*D_OFFSETS_GEMM2(D%NUMP+1) IF (PRESENT(IIN_STRIDES0)) & IIN_STRIDES0 = ALIGN(2*KF_FS,A) IF (PRESENT(IIN_SIZE)) & IIN_SIZE = IIN_STRIDES0*D_OFFSETS_GEMM1(D%NUMP+1) IF (PRESENT(IOUT0_STRIDES0)) & IOUT0_STRIDES0 = ALIGN(KF_FS,A) IF (PRESENT(IOUT0_SIZE)) & IOUT0_SIZE = IOUT0_STRIDES0 * ALIGN(MAX((R%NTMAX+2)/2,(R%NTMAX+3)/2),A) IF (PRESENT(IIN0_STRIDES0)) & IIN0_STRIDES0 = ALIGN(KF_FS,A) IF (PRESENT(IIN0_SIZE)) & IIN0_SIZE = IIN0_STRIDES0 * ALIGN(R%NDGNH,A) END ASSOCIATE END SUBROUTINE SUBROUTINE LEDIR(ALLOCATOR,ZINPS,ZINPA,ZINPS0,ZINPA0,ZOUT,ZOUT0,POA1,KF_FS) !**** *LEDIR* - Direct Legendre transform. ! Purpose. ! -------- ! Direct Legendre tranform of state variables. !** Interface. ! ---------- ! CALL LEDIR(...) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFC - number of field to transform ! fields for zonal wavenumber KM ! PSIA - symmetric part of Fourier ! fields for zonal wavenumber KM ! POA1 - spectral ! fields for zonal wavenumber KM ! Implicit arguments : None. ! -------------------- ! Method. ! ------- use butterfly or dgemm ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Nils Wedi + Mats Hamrud + George Modzynski ! Modifications. ! -------------- ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE TPM_GEN, ONLY: LSYNC_TRANS, NOUT, NCUR_RESOL USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS_GPU, ONLY: FG USE TPM_DISTR, ONLY: D USE HICBLAS_MOD, ONLY: HIP_DGEMM_BATCHED, & & HIP_DGEMM_GROUPED, HIP_SGEMM_GROUPED USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT, C_LONG, C_LOC #ifdef ACCGPU USE OPENACC_LIB, ONLY: ACC_GET_HIP_STREAM #endif #ifdef TRANS_SINGLE #define HIP_GEMM HIP_SGEMM_GROUPED #else #define HIP_GEMM HIP_DGEMM_GROUPED #endif IMPLICIT NONE ! DUMMY ARGUMENTS REAL(KIND=JPRBT), POINTER, INTENT(IN) :: ZINPS(:), ZINPA(:) REAL(KIND=JPRD), POINTER, INTENT(IN) :: ZINPS0(:), ZINPA0(:) REAL(KIND=JPRBT), POINTER, INTENT(INOUT) :: ZOUT(:) REAL(KIND=JPRD), POINTER, INTENT(INOUT) :: ZOUT0(:) REAL(KIND=JPRBT), INTENT(OUT), POINTER :: POA1(:,:,:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR ! LOCAL VARIABLES INTEGER(KIND=JPIM) :: KM INTEGER(KIND=JPIM) :: KMLOC INTEGER(KIND=JPIM) :: IA, IS, J, IMLOC0(1) INTEGER(KIND=JPIM) :: KS(D%NUMP), NS(D%NUMP) INTEGER(KIND=JPIB) :: AOFFSETS(D%NUMP), BOFFSETS(D%NUMP), COFFSETS(D%NUMP) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: JF INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_STRIDES1 INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_STRIDES1 INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_STRIDES1 INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_STRIDES1 INTEGER(KIND=C_LONG) :: HIP_STREAM ASSOCIATE(D_NUMP=>D%NUMP, R_NSMAX=>R%NSMAX, R_NTMAX=>R%NTMAX, G_NDGLU=>G%NDGLU, & & D_MYMS=>D%MYMS, D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1, & & D_OFFSETS_GEMM2=>D%OFFSETS_GEMM2, & & ZAA=>FG%ZAA, ZAS=>FG%ZAS, ZAA0=>FG%ZAA0, ZAS0=>FG%ZAS0) IF (LHOOK) CALL DR_HOOK('LE_DGEMM',0,ZHOOK_HANDLE) #ifdef ACCGPU HIP_STREAM = INT(ACC_GET_HIP_STREAM(1_C_INT), C_LONG) #endif #ifdef OMPGPU HIP_STREAM = 0_C_LONG #endif CALL LEDIR_STRIDES(KF_FS,IOUT_STRIDES0,IOUT_STRIDES1,IIN_STRIDES0,IIN_STRIDES1,& IOUT0_STRIDES0,IOUT0_STRIDES1,IIN0_STRIDES0,IIN0_STRIDES1) #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:ZINPS,ZINPA,ZOUT,ZINPS0,ZINPA0,ZOUT0) & !$OMP& MAP(PRESENT,ALLOC:D,D_MYMS,D_NUMP,R,R_NTMAX,R_NSMAX) & !$OMP& MAP(PRESENT,ALLOC:ZAA,ZAS,POA1,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2) #endif #ifdef ACCGPU !$ACC DATA & !$ACC& PRESENT(ZINPS,ZINPA,ZOUT,ZINPS0,ZINPA0,ZOUT0) & !$ACC& PRESENT(D,D_MYMS,D_NUMP,R,R_NTMAX,R_NSMAX) & !$ACC& PRESENT(ZAA,ZAS,POA1,D_OFFSETS_GEMM1,D_OFFSETS_GEMM2) #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(430,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(414,0) ! anti-symmetric IMLOC0 = FINDLOC(D_MYMS,0) IF(IMLOC0(1) > 0) THEN ! compute m=0 in double precision: #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAA0,ZINPA0,ZOUT0) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAA0,ZINPA0,ZOUT0) #endif CALL HIP_DGEMM_BATCHED( & & 'N', 'N', & & KF_FS, (R_NSMAX+2)/2, G_NDGLU(0), & & 1.0_JPRD, & & C_LOC(ZINPA0), IIN0_STRIDES0, 0, & & C_LOC(ZAA0), SIZE(ZAA0,1), 0, & & 0.0_JPRD, & & C_LOC(ZOUT0), IOUT0_STRIDES0, 0, & & 1, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END HOST_DATA #endif ENDIF ! Get C in transpose format to get better memory access patterns later !C=A*B => ! C^T=B^T*A^T DO KMLOC=1,D_NUMP KM = D_MYMS(KMLOC) NS(KMLOC) = (R_NSMAX-KM+2)/2 KS(KMLOC) = G_NDGLU(KM) AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC) BOFFSETS(KMLOC) = D%OFFSETS_GEMM_MATRIX(KMLOC) COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM2(KMLOC) ENDDO IF(IMLOC0(1) > 0) THEN NS(IMLOC0(1)) = 0 KS(IMLOC0(1)) = 0 ENDIF #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAA,ZINPA,ZOUT) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAA,ZINPA,ZOUT) #endif CALL HIP_GEMM( & & NCUR_RESOL, 21, & ! unique identifier & 'N', 'N', & & 2*KF_FS, NS(:), KS(:), & & 1.0_JPRBT, & & C_LOC(ZINPA), IIN_STRIDES0, AOFFSETS, & & C_LOC(ZAA), D%LEGENDRE_MATRIX_STRIDES, BOFFSETS, & & 0.0_JPRBT, & & C_LOC(ZOUT), IOUT_STRIDES0, COFFSETS, & & D_NUMP, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END HOST_DATA #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(434,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(434,1) ENDIF CALL GSTATS(414,1) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) DEFAULT(NONE) PRIVATE(KM,IA) & !$OMP& SHARED(D,R,KF_FS,IOUT_STRIDES0,ZOUT,IOUT0_STRIDES0,ZOUT0,POA1) & !$OMP& MAP(TO:KF_FS,IOUT_STRIDES0) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IA,J) FIRSTPRIVATE(KF_FS,IOUT_STRIDES0,IOUT0_STRIDES0) DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JF=1,2*KF_FS KM = D_MYMS(KMLOC) IA = 1+MOD(R_NTMAX-KM+2,2) IF (KM /= 0) THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX-KM+2)/2 POA1(JF,IA+1+(J-1)*2,KMLOC) = ZOUT(JF+(J-1)*IOUT_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IOUT_STRIDES0) ENDDO ELSEIF (MOD(JF-1,2) == 0) THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX+2)/2 POA1(JF,IA+1+(J-1)*2,KMLOC) = ZOUT0((JF-1)/2+1+(J-1)*IOUT0_STRIDES0) ENDDO ENDIF ENDDO ENDDO ! symmetric IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(430,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(414,0) IF(IMLOC0(1) > 0) THEN #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAS0,ZINPS0,ZOUT0) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAS0,ZINPS0,ZOUT0) #endif ! compute m=0 in double precision: call HIP_DGEMM_BATCHED( & & 'N', 'N', & & KF_FS, (R_NSMAX+3)/2, G_NDGLU(0), & & 1.0_JPRD, & & C_LOC(ZINPS0), IIN0_STRIDES0, 0, & & C_LOC(ZAS0), SIZE(ZAS0,1), 0, & & 0.0_JPRD, & & C_LOC(ZOUT0), IOUT0_STRIDES0, 0, & & 1, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END HOST_DATA #endif ENDIF ! Get C in transpose format to get better memory access patterns later !C=A*B => ! C^T=B^T*A^T DO KMLOC=1,D_NUMP KM = D_MYMS(KMLOC) NS(KMLOC) = (R_NSMAX-KM+3)/2 KS(KMLOC) = G_NDGLU(KM) AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM1(KMLOC) BOFFSETS(KMLOC) = D%OFFSETS_GEMM_MATRIX(KMLOC) COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM2(KMLOC) ENDDO IF(IMLOC0(1) > 0) THEN NS(IMLOC0(1)) = 0 KS(IMLOC0(1)) = 0 ENDIF #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAS,ZINPS,ZOUT) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAS,ZINPS,ZOUT) #endif CALL HIP_GEMM( & & NCUR_RESOL, 22, & ! unique identifier & 'N', 'N', & & 2*KF_FS, NS(:), KS(:), & & 1.0_JPRBT, & & C_LOC(ZINPS), IIN_STRIDES0, AOFFSETS, & & C_LOC(ZAS), D%LEGENDRE_MATRIX_STRIDES, BOFFSETS, & & 0.0_JPRBT, & & C_LOC(ZOUT), IOUT_STRIDES0, COFFSETS, & & D_NUMP, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END HOST_DATA #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(434,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(434,1) ENDIF CALL GSTATS(414,1) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) PRIVATE(KM,IS) & !$OMP& SHARED(D,R,KF_FS,IOUT_STRIDES0,ZOUT,POA1) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IS) FIRSTPRIVATE(KF_FS,IOUT_STRIDES0,IOUT0_STRIDES0) & !$ACC& DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JF=1,2*KF_FS KM = D_MYMS(KMLOC) IS = 1+MOD(R_NTMAX-KM+1,2) IF (KM /= 0) THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX-KM+3)/2 POA1(JF,IS+1+(J-1)*2,KMLOC) = ZOUT(JF+(J-1)*IOUT_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IOUT_STRIDES0) ENDDO ELSEIF (MOD(JF-1,2) == 0) THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX+3)/2 POA1(JF,IS+1+(J-1)*2,KMLOC) = ZOUT0((JF-1)/2+1+(J-1)*IOUT0_STRIDES0) ENDDO ENDIF ENDDO ENDDO #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('LE_DGEMM',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE LEDIR END MODULE LEDIR_MOD ectrans-1.8.0/src/trans/gpu/internal/leinv_mod.F900000775000175000017500000003525515174631767022162 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) #if defined CUDAGPU #define ACC_GET_HIP_STREAM ACC_GET_CUDA_STREAM #define OPENACC_LIB OPENACC #endif ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE LEINV_MOD USE PARKIND_ECTRANS, ONLY: JPIM, JPRB, JPRBT, JPRD, JPIB USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR IMPLICIT NONE PRIVATE PUBLIC :: LEINV_STRIDES, LEINV INTEGER(KIND=JPIM) :: A = 8 !Alignment CONTAINS SUBROUTINE LEINV_STRIDES(KF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG INTEGER(KIND=JPIM), OPTIONAL :: IOUT_STRIDES0 INTEGER(KIND=JPIB), OPTIONAL :: IOUT_SIZE INTEGER(KIND=JPIM), OPTIONAL :: IIN_STRIDES0 INTEGER(KIND=JPIB), OPTIONAL :: IIN_SIZE INTEGER(KIND=JPIM), OPTIONAL :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM), OPTIONAL :: IIN0_STRIDES0, IIN0_SIZE ASSOCIATE(D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1, D_OFFSETS_GEMM2=>D%OFFSETS_GEMM2) IF (PRESENT(IOUT0_STRIDES0)) & IOUT0_STRIDES0 = ALIGN(KF_LEG,A) IF (PRESENT(IOUT0_SIZE)) & IOUT0_SIZE = IOUT0_STRIDES0 * ALIGN(R%NDGNH,A) IF (PRESENT(IIN_STRIDES0)) & IIN_STRIDES0 = ALIGN(2*KF_LEG,A) IF (PRESENT(IIN_SIZE)) & IIN_SIZE = IIN_STRIDES0*D_OFFSETS_GEMM2(D%NUMP+1) IF (PRESENT(IOUT_STRIDES0)) & IOUT_STRIDES0 = ALIGN(2*KF_LEG,A) IF (PRESENT(IOUT_SIZE)) & IOUT_SIZE = IOUT_STRIDES0*D_OFFSETS_GEMM1(D%NUMP+1) IF (PRESENT(IIN0_STRIDES0)) & IIN0_STRIDES0 = ALIGN(KF_LEG,A) IF (PRESENT(IIN0_SIZE)) & IIN0_SIZE = IIN0_STRIDES0 * ALIGN(MAX((R%NTMAX+2)/2,(R%NTMAX+3)/2),A) END ASSOCIATE END SUBROUTINE LEINV_STRIDES SUBROUTINE LEINV(ALLOCATOR,PIA,ZINP,ZINP0,ZOUTS,ZOUTA,ZOUTS0,ZOUTA0,KF_LEG) !**** *LEINV* - Inverse Legendre transform. ! Purpose. ! -------- ! Inverse Legendre tranform of all variables(kernel). !** Interface. ! ---------- ! CALL LEINV(...) ! Explicit arguments : KM - zonal wavenumber (input-c) ! -------------------- KFC - number of fields to tranform (input-c) ! PIA - spectral fields ! for zonal wavenumber KM (input) ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Nils Wedi + Mats Hamrud + George Modzynski ! ! Modifications. ! -------------- ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE TPM_GEN, ONLY: LSYNC_TRANS, NOUT, NCUR_RESOL USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_DIM, ONLY: R USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS_GPU, ONLY: FG USE TPM_DISTR, ONLY: D USE HICBLAS_MOD, ONLY: HIP_DGEMM_BATCHED, & & HIP_DGEMM_GROUPED, HIP_SGEMM_GROUPED USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT, C_LONG, C_LOC USE MPL_MODULE, ONLY: MPL_BARRIER,MPL_ALL_MS_COMM USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX #ifdef ACCGPU USE OPENACC_LIB, ONLY: ACC_GET_HIP_STREAM #endif #ifdef TRANS_SINGLE #define HIP_GEMM HIP_SGEMM_GROUPED #else #define HIP_GEMM HIP_DGEMM_GROUPED #endif IMPLICIT NONE REAL(KIND=JPRB), INTENT(IN) :: PIA(:,:,:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG REAL(KIND=JPRBT), POINTER, INTENT(OUT) :: ZINP(:), ZOUTS(:), ZOUTA(:) REAL(KIND=JPRD), POINTER, INTENT(OUT) :: ZINP0(:), ZOUTS0(:), ZOUTA0(:) TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR ! LOCAL INTEGER(KIND=JPIM) :: KS(D%NUMP), NS(D%NUMP) INTEGER(KIND=JPIB) :: AOFFSETS(D%NUMP), BOFFSETS(D%NUMP), COFFSETS(D%NUMP) INTEGER(KIND=JPIM) :: KM, KMLOC, IA, IS, JK, J, IMLOC0(1) INTEGER(KIND=JPIM) :: IOUT_STRIDES0 INTEGER(KIND=JPIB) :: IOUT_SIZE INTEGER(KIND=JPIM) :: IIN_STRIDES0 INTEGER(KIND=JPIB) :: IIN_SIZE INTEGER(KIND=JPIM) :: IOUT0_STRIDES0, IOUT0_SIZE INTEGER(KIND=JPIM) :: IIN0_STRIDES0, IIN0_SIZE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=C_LONG) :: HIP_STREAM ASSOCIATE(D_NUMP=>D%NUMP, R_NSMAX=>R%NSMAX, G_NDGLU=>G%NDGLU, D_MYMS=>D%MYMS, D_OFFSETS_GEMM1=>D%OFFSETS_GEMM1,& D_OFFSETS_GEMM2=>D%OFFSETS_GEMM2, & ZAA=>FG%ZAA, ZAS=>FG%ZAS, ZAA0=>FG%ZAA0, ZAS0=>FG%ZAS0) !* 1.1 PREPARATIONS. IF (LHOOK) CALL DR_HOOK('LE_DGEMM',0,ZHOOK_HANDLE) #ifdef ACCGPU HIP_STREAM = INT(ACC_GET_HIP_STREAM(1_C_INT), C_LONG) #endif #ifdef OMPGPU HIP_STREAM = 0_C_LONG #endif ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- !* 1.1 PREPARATIONS. CALL LEINV_STRIDES(KF_LEG,IOUT_STRIDES0,IOUT_SIZE,IIN_STRIDES0,IIN_SIZE,& IOUT0_STRIDES0,IOUT0_SIZE,IIN0_STRIDES0,IIN0_SIZE) #ifdef OMPGPU !$OMP TARGET DATA & !$OMP& MAP(PRESENT,ALLOC:D,D_MYMS,D_NUMP) & !$OMP& MAP(PRESENT,ALLOC:ZINP,ZOUTS,ZOUTA,ZINP0,ZOUTS0,ZOUTA0) & !$OMP& MAP(PRESENT,ALLOC:ZAA,ZAS,PIA) & !$OMP& MAP(PRESENT,ALLOC:R,R_NSMAX,D_OFFSETS_GEMM2) #endif #ifdef ACCGPU !$ACC DATA PRESENT(D,D_MYMS,D_NUMP) & !$ACC& PRESENT(ZINP,ZOUTS,ZOUTA,ZINP0,ZOUTS0,ZOUTA0) & !$ACC& PRESENT(ZAA,ZAS,PIA) & !$ACC& PRESENT(R,R_NSMAX,D_OFFSETS_GEMM2) #endif ! READ 2:NSMAX+3 !IF KM=0 and NSMAX is 6: ! IA=1 ! DO=1,6/2+1 ... 1..4 ! PIA_2=1+1+(J-1)*2 ...2+(0..3)*2 .... 2,4,6,8 !IF KM=0 and NSMAX is 7: ! IA=2 ! DO=1,7/2+1 ... 1..4 ! PIA_2=2+1+(1..4-1)*2 ...3+(0..3)*2 .... 3,5,7,9 #ifdef OMPGPU ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) & !$OMP& PRIVATE(KM,IA,J) & !$OMP& SHARED(D,R,KF_LEG,ZINP,IIN_STRIDES0,IIN0_STRIDES0) MAP(TO:KF_LEG) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IA,J) & !$ACC& FIRSTPRIVATE(KF_LEG,IIN_STRIDES0,IIN0_STRIDES0) DEFAULT(NONE) & #ifdef _CRAYFTN !$ACC& #else !$ACC& ASYNC(1) #endif #endif DO KMLOC=1,D_NUMP DO JK=1,2*KF_LEG KM = D_MYMS(KMLOC) IA = 1+MOD(R_NSMAX-KM+2,2) IF(KM /= 0)THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX-KM+2)/2 ZINP(JK+(J-1)*IIN_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IIN_STRIDES0)=PIA(JK,IA+1+(J-1)*2,KMLOC) ENDDO ! those are only needed with tensor cores (zinp might contain NaNs!) #if defined(USE_CUTLASS) && defined(USE_CUTLASS_3XTF32) !$ACC LOOP SEQ DO J=(R_NSMAX-KM+2)/2+1,ALIGN((R_NSMAX-KM+2)/2,A) ZINP(JK+(J-1)*IIN_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IIN_STRIDES0)=0 ENDDO #endif ELSEIF (MOD((JK-1),2) == 0) THEN ! every other field is sufficient because Im(KM=0) == 0 #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX+2)/2 ZINP0((JK-1)/2+1+(J-1)*IIN0_STRIDES0) = PIA(JK,IA+1+(J-1)*2,KMLOC) ENDDO ! those are only needed with tensor cores (zinp might contain NaNs!) #if defined(USE_CUTLASS) && defined(USE_CUTLASS_3XTF32) !$ACC LOOP SEQ DO J=(R_NSMAX+2)/2+1,ALIGN((R_NSMAX+2)/2,A) ZINP0((JK-1)/2+1+(J-1)*IIN0_STRIDES0) = 0 ENDDO #endif ENDIF ENDDO ENDDO IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(440,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(424,0) IMLOC0 = FINDLOC(D_MYMS,0) IF (IMLOC0(1) > 0) THEN ! compute m=0 in double precision #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAA0,ZINP0,ZOUTA0) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAA0,ZINP0,ZOUTA0) #endif CALL HIP_DGEMM_BATCHED( & & 'N', 'T', & & KF_LEG, G_NDGLU(0), (R_NSMAX+2)/2, & & 1.0_JPRD, & & C_LOC(ZINP0), IIN0_STRIDES0, 0, & & C_LOC(ZAA0), SIZE(ZAA0,1), 0, & & 0.0_JPRD, & & C_LOC(ZOUTA0), IOUT0_STRIDES0, 0, & & 1, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif ENDIF DO KMLOC=1,D_NUMP KM = D_MYMS(KMLOC) KS(KMLOC) = (R_NSMAX-KM+2)/2 NS(KMLOC) = G_NDGLU(KM) AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM2(KMLOC) BOFFSETS(KMLOC) = D%OFFSETS_GEMM_MATRIX(KMLOC) COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM1(KMLOC) ENDDO IF(IMLOC0(1) > 0) THEN NS(IMLOC0(1)) = 0 KS(IMLOC0(1)) = 0 ENDIF #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAA,ZINP,ZOUTA) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAA,ZINP,ZOUTA) #endif CALL HIP_GEMM( & & NCUR_RESOL, 11, & ! unique identifier & 'N', 'T', & & 2*KF_LEG, NS(:), KS(:), & & 1.0_JPRBT, & & C_LOC(ZINP), IIN_STRIDES0, AOFFSETS, & & C_LOC(ZAA), D%LEGENDRE_MATRIX_STRIDES, BOFFSETS, & & 0.0_JPRBT, & & C_LOC(ZOUTA), IOUT_STRIDES0, COFFSETS, & & D_NUMP, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(444,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(444,1) ENDIF CALL GSTATS(424,1) ! 2. +++++++++++++ symmetric !IF KM=0 and NSMAX is 6: ! IS=2 ! DO=1,4 ! PIA_2=2+1+(0..3)*2 ... 3+(0..3)*2 ... 3,5,7,9 !IF KM=0 and NSMAX is 7: ! IS=1 ! DO=1,5 ! PIA_2=1+1+(1..5-1)*2 ...2+(0..4)*2 .... 2,4,6,8,10 #ifdef OMPGPU ! Directive incomplete -> putting more variables in SHARED() triggers internal compiler error ! ftn-7991: INTERNAL COMPILER ERROR: "Too few arguments on the stack" !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) & !$OMP& PRIVATE(KM,IS,J) & !$OMP& SHARED(D,R,KF_LEG,ZINP,IIN_STRIDES0,IIN0_STRIDES0) MAP(TO:KF_LEG) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP COLLAPSE(2) PRIVATE(KM,IS,J) & !$ACC& FIRSTPRIVATE(KF_LEG,IIN_STRIDES0,IIN0_STRIDES0) DEFAULT(NONE) & #ifndef _CRAYFTN !$ACC& ASYNC(1) #else !$ACC& #endif #endif DO KMLOC=1,D_NUMP DO JK=1,2*KF_LEG KM = D_MYMS(KMLOC) IS = 1+MOD(R_NSMAX-KM+1,2) IF(KM /= 0) THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX-KM+3)/2 ZINP(JK+(J-1)*IIN_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IIN_STRIDES0)=PIA(JK,IS+1+(J-1)*2,KMLOC) ENDDO #if defined(USE_CUTLASS) && defined(USE_CUTLASS_3XTF32) ! those are only needed with tensor cores (zinp might contain NaNs!) !$ACC LOOP SEQ DO J=(R_NSMAX-KM+3)/2+1,ALIGN((R_NSMAX-KM+3)/2,A) ZINP(JK+(J-1)*IIN_STRIDES0+D_OFFSETS_GEMM2(KMLOC)*IIN_STRIDES0)=0 ENDDO #endif ELSEIF (MOD((JK-1),2) == 0) THEN #ifdef ACCGPU !$ACC LOOP SEQ #endif DO J=1,(R_NSMAX+3)/2 ZINP0((JK-1)/2+1+(J-1)*IIN0_STRIDES0) = PIA(JK,IS+1+(J-1)*2,KMLOC) ENDDO ! those are only needed with tensor cores (zinp might contain NaNs!) #if defined(USE_CUTLASS) && defined(USE_CUTLASS_3XTF32) !$ACC LOOP SEQ DO J=(R_NSMAX+3)/2+1,ALIGN((R_NSMAX+3)/2,A) ZINP0((JK-1)/2+1+(J-1)*IIN0_STRIDES0) = 0 ENDDO #endif ENDIF ENDDO ENDDO IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(440,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(424,0) IF (IMLOC0(1) > 0) THEN #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAS0,ZINP0,ZOUTS0) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAS0,ZINP0,ZOUTS0) #endif CALL HIP_DGEMM_BATCHED( & & 'N', 'T', & & KF_LEG, G_NDGLU(0), (R_NSMAX+3)/2, & & 1.0_JPRD, & & C_LOC(ZINP0), IIN0_STRIDES0, 0, & & C_LOC(ZAS0), SIZE(ZAS0,1), 0, & & 0.0_JPRD, & & C_LOC(ZOUTS0), IOUT0_STRIDES0, 0, & & 1, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif ENDIF DO KMLOC=1,D_NUMP KM = D_MYMS(KMLOC) KS(KMLOC) = (R_NSMAX-KM+3)/2 NS(KMLOC) = G_NDGLU(KM) AOFFSETS(KMLOC) = IIN_STRIDES0*D_OFFSETS_GEMM2(KMLOC) BOFFSETS(KMLOC) = D%OFFSETS_GEMM_MATRIX(KMLOC) COFFSETS(KMLOC) = IOUT_STRIDES0*D_OFFSETS_GEMM1(KMLOC) ENDDO IF(IMLOC0(1) > 0) THEN NS(IMLOC0(1)) = 0 KS(IMLOC0(1)) = 0 ENDIF #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(ZAS,ZINP,ZOUTS) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(ZAS,ZINP,ZOUTS) #endif CALL HIP_GEMM( & & NCUR_RESOL, 12, & ! unique identifier & 'N', 'T', & & 2*KF_LEG, NS(:), KS(:), & & 1.0_JPRBT, & & C_LOC(ZINP), IIN_STRIDES0, AOFFSETS, & & C_LOC(ZAS), D%LEGENDRE_MATRIX_STRIDES, BOFFSETS, & & 0.0_JPRBT, & & C_LOC(ZOUTS), IOUT_STRIDES0, COFFSETS, & & D_NUMP, HIP_STREAM, C_LOC(ALLOCATOR%PTR)) #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif IF (LSYNC_TRANS) THEN #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(444,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(444,1) ENDIF CALL GSTATS(424,1) #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC WAIT(1) !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('LE_DGEMM',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END ASSOCIATE END SUBROUTINE LEINV END MODULE LEINV_MOD ectrans-1.8.0/src/trans/gpu/internal/dist_grid_ctl_mod.F900000775000175000017500000001665215174631767023657 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! MODULE DIST_GRID_CTL_MOD CONTAINS SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT) !**** *DIST_GRID_CTL* - Distributing global gridpoint array to processors ! Purpose. ! -------- ! Routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint output ! KFROM(:) - Processor responsible for distributing each field ! PGP(:,:,:) - Local spectral array ! KSORT(:) - Add KSORT ! Externals. SET2PE - compute "A and B" set from PE ! ---------- MPL.. - message passing routines ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! P.Marguinaud : 2014-10-10 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB USE MPL_MODULE, ONLY: MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, JP_NON_BLOCKING_STANDARD USE TPM_DISTR, ONLY: D, MTAGDISTGP, NPRCIDS, MYPROC, NPROC USE TPM_GEOMETRY, ONLY: G USE SET2PE_MOD, ONLY: SET2PE USE EQ_REGIONS_MOD, ONLY: N_REGIONS, N_REGIONS_NS ! IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN), TARGET :: KSORT (:) ! Declaration of local variables ! SS/2018: Removed stack hogs !REAL(KIND=JPRB) :: ZDUM(D%NGPTOTMX) -- not used REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:,:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZRCV(:,:) ! (D%NGPTOTMX,KFDISTG) INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG), IRECVREQ(KFDISTG) INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD INTEGER(KIND=JPIM), POINTER :: ISORT (:) LOGICAL :: LLSAME ! ------------------------------------------------------------------ IF (PRESENT (KSORT)) THEN ISORT => KSORT ELSE ALLOCATE (ISORT (KFDISTG)) DO JFLD = 1, KFDISTG ISORT (JFLD) = JFLD ENDDO ENDIF ! Copy for single PE IF(NPROC == 1) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ELSEIF(KFDISTG>0) THEN ! test if values in KFROM are all the same LLSAME=.TRUE. IFROM=KFROM(1) DO JFLD=2,KFDISTG IF(KFROM(JFLD) /= IFROM) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO IMYFIELDS = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO CALL GSTATS(1663,0) IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILOFF,JGL,JLON) DO JFLD=1,IMYFIELDS DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(ISND,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN(ISND,JFLD) = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = & & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) ENDDO ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1663,1) ! Message passing CALL GSTATS_BARRIER(791) CALL GSTATS(811,0) ! Receive ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG)) IF( LLSAME )THEN IRCV = KFROM(1) ITAG = MTAGDISTGP CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:') ELSE DO JFLD=1,KFDISTG IRCV = KFROM(JFLD) ITAG = MTAGDISTGP+JFLD CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:') ENDDO ENDIF ! Send IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN ITAG = MTAGDISTGP DO JROC=1,NPROC CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),& &CDSTRING='DIST_GRID_CTL') ENDDO ENDIF ELSE IFLD = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN IFLD = IFLD+1 ITAG = MTAGDISTGP+JFLD DO JROC=1,NPROC CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),& &CDSTRING='DIST_GRID_CTL') ENDDO ENDIF ENDDO ENDIF ! Wait for sends and receives to complete IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), & & CDSTRING='DIST_GRID_CTL: WAIT 1') ENDIF CALL MPL_WAIT(KREQUEST=IRECVREQ(1), & & CDSTRING='DIST_GRID_CTL: WAIT 2') ELSE DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,JFLD), & & CDSTRING='DIST_GRID_CTL: WAIT 3') ENDIF CALL MPL_WAIT(KREQUEST=IRECVREQ(JFLD), & & CDSTRING='DIST_GRID_CTL: WAIT 4') ENDDO ENDIF CALL GSTATS(811,1) CALL GSTATS_BARRIER2(791) CALL GSTATS(1663,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,ISORT(JFLD),IBL) = ZRCV(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1663,1) DEALLOCATE(ZRCV) !Synchronize processors CALL GSTATS(786,0) CALL MPL_BARRIER(CDSTRING='DIST_GRID_CTL:') CALL GSTATS(786,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF IF (.NOT. PRESENT (KSORT)) THEN DEALLOCATE (ISORT) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID_CTL END MODULE DIST_GRID_CTL_MOD ectrans-1.8.0/src/trans/gpu/internal/trmtol_mod.F900000775000175000017500000002113015174631767022351 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRMTOL_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRMTOL, PREPARE_TRMTOL, TRMTOL_HANDLE TYPE TRMTOL_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HPFBUF END TYPE CONTAINS FUNCTION PREPARE_TRMTOL(ALLOCATOR, KF_LEG) RESULT(HTRMTOL) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_LEG TYPE(TRMTOL_HANDLE) :: HTRMTOL REAL(KIND=JPRBT) :: DUMMY HTRMTOL%HPFBUF = RESERVE(ALLOCATOR, 2_JPIB*D%NLENGT0B*KF_LEG*C_SIZEOF(DUMMY), "HTRMTOL%HPFBUF") END FUNCTION SUBROUTINE TRMTOL(ALLOCATOR,HTRMTOL,PFBUF_IN,PFBUF,KF_LEG) !**** *trmtol * - transposition in Fourier space ! Purpose. ! -------- ! Transpose Fourier buffer data from partitioning ! over wave numbers to partitioning over latitudes. ! It is called between direct FFT and direct Legendre ! transform. ! This routine is the inverse of TRLTOM. !** Interface. ! ---------- ! *call* *trmtol(...)* ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is ! -------------------- used for both input and output. ! KF_LEG - Number of fields communicated ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified : 97-06-17 G. Mozdzynski - control MPI mailbox use ! (NCOMBFLEN) for nphase.eq.1 ! Modified : 99-05-28 D.Salmond - Optimise copies. ! Modified : 00-02-02 M.Hamrud - Remove NPHASE ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message ! passing and buffer packing ! G.Mozdzynski: 08-01-01 Cleanup ! Y.Seity : 07-08-31 add barrier synchronisation under LSYNC_TRANS ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK USE TPM_DISTR, ONLY: D, NPRTRW, NPROC, MYSETW USE TPM_GEN, ONLY: LSYNC_TRANS, NERR, LMPOFF #ifdef USE_RAW_MPI USE MPI_F08, ONLY: MPI_COMM, MPI_REAL4, MPI_REAL8 ! Missing: MPI_ALLTOALLV on purpose due to cray-mpi bug (see https://github.com/ecmwf-ifs/ectrans/pull/157) #endif USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE ISO_C_BINDING, ONLY: C_SIZEOF USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_LEG REAL(KIND=JPRBT), INTENT(OUT), POINTER :: PFBUF(:) REAL(KIND=JPRBT), INTENT(IN), POINTER :: PFBUF_IN(:) INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) INTEGER(KIND=JPIM) :: J, FROM_SEND, TO_SEND, FROM_RECV, TO_RECV, IRANK INTEGER(KIND=JPIB) :: JPOS, ISTA, IEND, ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IERROR TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRMTOL_HANDLE), INTENT(IN) :: HTRMTOL #ifdef USE_RAW_MPI TYPE(MPI_COMM) :: LOCAL_COMM #endif #ifdef PARKINDTRANS_SINGLE #define TRMTOL_DTYPE MPI_REAL4 #else #define TRMTOL_DTYPE MPI_REAL8 #endif #ifdef USE_RAW_MPI IF(.NOT. LMPOFF) THEN LOCAL_COMM%MPI_VAL = MPL_ALL_MS_COMM ENDIF #endif IF (LHOOK) CALL DR_HOOK('TRMTOL',0,ZHOOK_HANDLE) CALL ASSIGN_PTR(PFBUF, GET_ALLOCATION(ALLOCATOR, HTRMTOL%HPFBUF),& & 1_JPIB, 2_JPIB*D%NLENGT0B*KF_LEG*C_SIZEOF(PFBUF(1))) IF(NPROC > 1) THEN DO J=1,NPRTRW ILENS(J) = D%NLTSFTB(J)*2*KF_LEG IOFFS(J) = D%NSTAGT1B(J)*2*KF_LEG ILENR(J) = D%NLTSGTB(J)*2*KF_LEG IOFFR(J) = D%NSTAGT0B(J)*2*KF_LEG ENDDO CALL GSTATS(807,0) ! copy to self workaround IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) IF (ILENS(IRANK) /= ILENR(IRANK)) THEN WRITE(NERR,*) "ERROR", ILENS(IRANK), ILENR(IRANK) CALL ABORT_TRANS("TRMTOL: ILENS(IRANK) /= ILENR(IRANK)") ENDIF IF (ILENS(IRANK) > 0) THEN FROM_SEND = IOFFS(IRANK) + 1 TO_SEND = FROM_SEND + ILENS(IRANK) - 1 FROM_RECV = IOFFR(IRANK) + 1 TO_RECV = FROM_RECV + ILENR(IRANK) - 1 #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) SHARED(PFBUF,PFBUF_IN,FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) DO JPOS=FROM_SEND,TO_SEND PFBUF(JPOS-FROM_SEND+FROM_RECV) = PFBUF_IN(JPOS) ENDDO !$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO #endif #ifdef ACCGPU #ifdef __HIP_PLATFORM_AMD__ ! Workaround for AMD GPUs - ASYNC execution of this kernel gives numerical errors !$ACC KERNELS DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) COPYIN(FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) #else !$ACC KERNELS ASYNC(1) DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) COPYIN(FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) #endif PFBUF(FROM_RECV:TO_RECV) = PFBUF_IN(FROM_SEND:TO_SEND) !$ACC END KERNELS #endif ILENS(IRANK) = 0 ILENR(IRANK) = 0 ENDIF IF (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(421,0) #ifdef USE_GPU_AWARE_MPI #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_ADDR(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PFBUF_IN,PFBUF) #endif #endif #ifdef USE_RAW_MPI CALL MPI_ALLTOALLV(PFBUF_IN,ILENS,IOFFS,TRMTOL_DTYPE,& & PFBUF,ILENR,IOFFR,TRMTOL_DTYPE,& & LOCAL_COMM,IERROR) #else CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN, KSENDCOUNTS=ILENS, PRECVBUF=PFBUF, KRECVCOUNTS=ILENR, & & KSENDDISPL=IOFFS, KRECVDISPL=IOFFR, KCOMM=MPL_ALL_MS_COMM, & & CDSTRING='TRMTOL:') #endif #ifdef USE_GPU_AWARE_MPI #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef ACCGPU !$ACC UPDATE DEVICE(PFBUF) #endif #ifdef OMPGPU !$OMP TARGET UPDATE TO(PFBUF) #endif #endif IF (LSYNC_TRANS) THEN CALL GSTATS(441,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(441,1) ENDIF CALL GSTATS(421,1) #ifdef ACCGPU #ifndef __HIP_PLATFORM_AMD__ ! Workaround for AMD GPUs - ASYNC execution of this kernel gives numerical errors !$ACC WAIT(1) #endif #endif CALL GSTATS(807,1) ELSE ILEN = 2_JPIB*D%NLTSGTB(MYSETW)*KF_LEG ISTA = 2_JPIB*D%NSTAGT0B(MYSETW)*KF_LEG+1 IEND = ISTA+ILEN-1 CALL GSTATS(1608,0) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(PFBUF,PFBUF_IN,ISTA,IEND) MAP(TO:ISTA,IEND) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) PRESENT(PFBUF,PFBUF_IN) FIRSTPRIVATE(ISTA,IEND) #endif DO JPOS=ISTA,IEND PFBUF(JPOS) = PFBUF_IN(JPOS) ENDDO CALL GSTATS(1608,1) ENDIF IF (LHOOK) CALL DR_HOOK('TRMTOL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRMTOL END MODULE TRMTOL_MOD ectrans-1.8.0/src/trans/gpu/internal/trltomad_mod.F900000775000175000017500000002075215174631767022667 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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. ! MODULE TRLTOMAD_MOD USE BUFFERED_ALLOCATOR_MOD, ONLY: ALLOCATION_RESERVATION_HANDLE IMPLICIT NONE PRIVATE PUBLIC :: TRLTOMAD, PREPARE_TRLTOMAD, TRLTOMAD_HANDLE TYPE TRLTOMAD_HANDLE TYPE(ALLOCATION_RESERVATION_HANDLE) :: HFOUBUF_IN END TYPE CONTAINS FUNCTION PREPARE_TRLTOMAD(ALLOCATOR, KF_FS) RESULT(HTRLTOMAD) USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE TPM_DISTR, ONLY: D USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, RESERVE USE ISO_C_BINDING, ONLY: C_SIZEOF IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS TYPE(TRLTOMAD_HANDLE) :: HTRLTOMAD INTEGER(KIND=JPIB) :: IALLOC_SZ REAL(KIND=JPRBT) :: DUMMY IALLOC_SZ = 2_JPIB*D%NLENGT0B*KF_FS*C_SIZEOF(DUMMY) HTRLTOMAD%HFOUBUF_IN = RESERVE(ALLOCATOR, IALLOC_SZ, "HTRLTOM%HFOUBUF_IN") END FUNCTION SUBROUTINE TRLTOMAD(ALLOCATOR,HTRLTOMAD,PFBUF_IN,PFBUF,KF_FS) !**** *TRLTOMAD * - transposition in Fourierspace ! Purpose. ! -------- ! Transpose Fourier coefficients from partitioning ! over latitudes to partitioning over wave numbers ! This is done between inverse Legendre Transform ! and inverse FFT. ! This is the inverse routine of TRMTOLAD. !** Interface. ! ---------- ! *CALL* *TRLTOMAD(...)* ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is ! -------------------- used for both input and output. ! KF_FS - Number of fields communicated ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified : 97-06-17 G. Mozdzynski - control MPI mailbox use ! (NCOMBFLEN) for nphase.eq.1 ! Modified : 99-05-28 D.Salmond - Optimise copies. ! Modified : 00-02-02 M.Hamrud - Remove NPHASE ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message ! passing and buffer packing ! G.Mozdzynski: 08-01-01 Cleanup ! Y.Seity : 07-08-31 add barrier synchronisation under LSYNC_TRANS ! ------------------------------------------------------------------ USE PARKIND_ECTRANS, ONLY: JPIM, JPRBT, JPIB USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK USE TPM_DISTR, ONLY: D, NPRTRW, NPROC, MYSETW USE TPM_GEN, ONLY: LSYNC_TRANS, NERR, LMPOFF #ifdef USE_RAW_MPI USE MPI_F08, ONLY: MPI_COMM, MPI_REAL4, MPI_REAL8 ! Missing: MPI_ALLTOALLV on purpose due to cray-mpi bug (see https://github.com/ecmwf-ifs/ectrans/pull/157) #endif USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, ASSIGN_PTR, GET_ALLOCATION USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX USE ISO_C_BINDING, ONLY: C_SIZEOF USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS REAL(KIND=JPRBT) ,INTENT(INOUT), POINTER :: PFBUF(:) REAL(KIND=JPRBT) ,INTENT(OUT) , POINTER :: PFBUF_IN(:) INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) INTEGER(KIND=JPIM) :: J, FROM_SEND, TO_SEND, FROM_RECV, TO_RECV, IRANK INTEGER(KIND=JPIB) :: JPOS, ISTA, IEND, ILEN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IERROR TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(TRLTOMAD_HANDLE), INTENT(IN) :: HTRLTOMAD #ifdef USE_RAW_MPI TYPE(MPI_COMM) :: LOCAL_COMM #endif #ifdef PARKINDTRANS_SINGLE #define TRLTOMAD_DTYPE MPI_REAL4 #else #define TRLTOMAD_DTYPE MPI_REAL8 #endif #ifdef USE_RAW_MPI IF(.NOT. LMPOFF) THEN LOCAL_COMM%MPI_VAL = MPL_ALL_MS_COMM ENDIF #endif IF (LHOOK) CALL DR_HOOK('TRLTOMAD',0,ZHOOK_HANDLE) CALL ASSIGN_PTR(PFBUF_IN, GET_ALLOCATION(ALLOCATOR, HTRLTOMAD%HFOUBUF_IN),& & 1_JPIB, 2_JPIB*D%NLENGT0B*KF_FS*C_SIZEOF(PFBUF_IN(1))) #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:PFBUF,PFBUF_IN) #endif #ifdef ACCGPU !$ACC DATA PRESENT(PFBUF,PFBUF_IN) #endif IF(NPROC > 1) THEN DO J=1,NPRTRW ILENS(J) = D%NLTSGTB(J)*2*KF_FS IOFFS(J) = D%NSTAGT0B(J)*2*KF_FS ILENR(J) = D%NLTSFTB(J)*2*KF_FS IOFFR(J) = D%NSTAGT1B(J)*2*KF_FS ENDDO CALL GSTATS(806,0) ! copy to self workaround IRANK = MPL_MYRANK(MPL_ALL_MS_COMM) IF (ILENS(IRANK) /= ILENR(IRANK)) THEN WRITE(NERR,*) "ERROR", ILENS(IRANK), ILENR(IRANK) CALL ABORT_TRANS("TRLTOMAD: Error - ILENS(IRANK) /= ILENR(IRANK)") ENDIF IF (ILENS(IRANK) > 0) THEN FROM_SEND = IOFFS(IRANK) + 1 TO_SEND = FROM_SEND + ILENS(IRANK) - 1 FROM_RECV = IOFFR(IRANK) + 1 TO_RECV = FROM_RECV + ILENR(IRANK) - 1 #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) FIRSTPRIVATE(PFBUF,PFBUF_IN,FROM_RECV,TO_RECV,FROM_SEND,TO_SEND) DO JPOS=FROM_RECV,TO_RECV PFBUF_IN(JPOS-FROM_RECV+FROM_SEND) = PFBUF(JPOS) ENDDO !$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO #endif #ifdef ACCGPU !$ACC KERNELS ASYNC(1) PFBUF_IN(FROM_SEND:TO_SEND) = PFBUF(FROM_RECV:TO_RECV) !$ACC END KERNELS #endif ILENS(IRANK) = 0 ILENR(IRANK) = 0 ENDIF IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(411,0) #ifdef USE_GPU_AWARE_MPI #ifdef OMPGPU !$OMP TARGET DATA USE_DEVICE_PTR(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC HOST_DATA USE_DEVICE(PFBUF_IN, PFBUF) #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE FROM(PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC UPDATE HOST(PFBUF_IN,PFBUF) #endif #endif #ifdef USE_RAW_MPI CALL MPI_ALLTOALLV(PFBUF, ILENR, IOFFR, TRLTOMAD_DTYPE, PFBUF_IN, ILENS, IOFFS, & & TRLTOMAD_DTYPE, LOCAL_COMM,IERROR) #else CALL MPL_ALLTOALLV(PSENDBUF=PFBUF, KSENDCOUNTS=ILENR, PRECVBUF=PFBUF_IN, KRECVCOUNTS=ILENS, & & KSENDDISPL=IOFFR, KRECVDISPL=IOFFS, KCOMM=MPL_ALL_MS_COMM, & & CDSTRING='TRLTOMAD:') #endif #ifdef USE_GPU_AWARE_MPI #ifdef ACCGPU !$ACC END HOST_DATA #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #else !! this is safe-but-slow fallback for running without GPU-aware MPI #ifdef OMPGPU !$OMP TARGET UPDATE TO(PFBUF_IN) #endif #ifdef ACCGPU !$ACC UPDATE DEVICE(PFBUF_IN) #endif #endif IF (LSYNC_TRANS) THEN CALL GSTATS(431,0) CALL MPL_BARRIER(MPL_ALL_MS_COMM,CDSTRING='') CALL GSTATS(431,1) ENDIF CALL GSTATS(411,1) #ifdef ACCGPU !$ACC WAIT(1) #endif CALL GSTATS(806,1) ELSE ILEN = 2_JPIB*D%NLTSGTB(MYSETW)*KF_FS ISTA = 2_JPIB*D%NSTAGT1B(MYSETW)*KF_FS+1 IEND = ISTA+ILEN-1 CALL GSTATS(1607,0) #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(IEND,ISTA,PFBUF_IN,PFBUF) #endif #ifdef ACCGPU !$ACC PARALLEL LOOP DEFAULT(NONE) FIRSTPRIVATE(ISTA,IEND) #endif DO JPOS=ISTA,IEND PFBUF_IN(JPOS) = PFBUF(JPOS) ENDDO CALL GSTATS(1607,1) ENDIF #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif IF (LHOOK) CALL DR_HOOK('TRLTOMAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRLTOMAD END MODULE TRLTOMAD_MOD ectrans-1.8.0/src/trans/gpu/algor/0000775000175000017500000000000015174631767017201 5ustar alastairalastairectrans-1.8.0/src/trans/gpu/algor/hicblas_gemm.cuda.cu0000777000175000017500000000000015174631767026747 2hicblas_gemm.hip.cppustar alastairalastairectrans-1.8.0/src/trans/gpu/algor/ext_acc.F900000664000175000017500000003175015174631767021075 0ustar alastairalastair! (C) Copyright 2022- NVIDIA. ! ! 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. module openacc_ext_type use iso_c_binding, only: c_size_t implicit none private public :: ext_acc_arr_desc ! to my knowledge, this cannot be part of openacc_ext type ext_acc_arr_desc integer(c_size_t) :: ptr, sz end type end module module openacc_ext use iso_c_binding, only: c_ptr, c_size_t, c_loc, c_sizeof, c_f_pointer #ifdef ACCGPU use openacc, only: acc_handle_kind #endif #ifdef OMPGPU #endif use openacc_ext_type, only: ext_acc_arr_desc implicit none private public :: ext_acc_pass, ext_acc_create, ext_acc_copyin, ext_acc_copyout, & #ifdef ACCGPU & ext_acc_delete, ext_acc_arr_desc, acc_handle_kind #endif #ifdef OMPGPU & ext_acc_delete, ext_acc_arr_desc #endif type common_pointer_descr type(c_ptr) :: ptr integer(c_size_t) :: sz end type interface ext_acc_pass module procedure ext_acc_pass_2d_r4, ext_acc_pass_3d_r4, ext_acc_pass_4d_r4 module procedure ext_acc_pass_2d_r8, ext_acc_pass_3d_r8, ext_acc_pass_4d_r8 end interface contains function ext_acc_pass_2d_r4(arr) result(ret) use iso_fortran_env, only: real32 implicit none type(ext_acc_arr_desc) :: ret real(kind=real32), intent(in), target :: arr(:,:) type(c_ptr) :: ptr1, ptr2 integer(c_size_t) :: ptr1_v, ptr2_v ! get full slices for all but the last slice ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1)) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%ptr = ptr1_v ret%sz = (ptr2_v - ptr1_v) * (size(arr, 2) - 1) ! for the last slice, take the actual offset, otherwise we imght go OOB ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) ptr2 = c_loc(arr(lbound(arr,1)+1, lbound(arr,2))) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 1) end function function ext_acc_pass_3d_r4(arr) result(ret) use iso_fortran_env, only: real32 implicit none type(ext_acc_arr_desc) :: ret real(kind=real32), intent(in), target :: arr(:,:,:) type(c_ptr) :: ptr1, ptr2 integer(c_size_t) :: ptr1_v, ptr2_v ! get full slices for all but the last slice ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3)+1)) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%ptr = ptr1_v ret%sz = (ptr2_v - ptr1_v) * (size(arr, 3) - 1) ! for the last slice, take the actual offset, otherwise we imght go OOB ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1, lbound(arr,3))) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 2) end function function ext_acc_pass_4d_r4(arr) result(ret) use iso_fortran_env, only: real32 implicit none type(ext_acc_arr_desc) :: ret real(kind=real32), intent(in), target :: arr(:,:,:,:) type(c_ptr) :: ptr1, ptr2 integer(c_size_t) :: ptr1_v, ptr2_v ! get full slices for all but the last slice ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4)+1)) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%ptr = ptr1_v ret%sz = (ptr2_v - ptr1_v) * (size(arr, 4) - 1) ! for the last slice, take the actual offset, otherwise we imght go OOB ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3)+1, lbound(arr,4))) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 3) end function function ext_acc_pass_2d_r8(arr) result(ret) use iso_fortran_env, only: real64 implicit none type(ext_acc_arr_desc) :: ret real(kind=real64), intent(in), target :: arr(:,:) type(c_ptr) :: ptr1, ptr2 integer(c_size_t) :: ptr1_v, ptr2_v ! get full slices for all but the last slice ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1)) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%ptr = ptr1_v ret%sz = (ptr2_v - ptr1_v) * (size(arr, 2) - 1) ! for the last slice, take the actual offset, otherwise we imght go OOB ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2))) ptr2 = c_loc(arr(lbound(arr,1)+1, lbound(arr,2))) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 1) end function function ext_acc_pass_3d_r8(arr) result(ret) use iso_fortran_env, only: real64 implicit none type(ext_acc_arr_desc) :: ret real(kind=real64), intent(in), target :: arr(:,:,:) type(c_ptr) :: ptr1, ptr2 integer(c_size_t) :: ptr1_v, ptr2_v ! get full slices for all but the last slice ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3)+1)) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%ptr = ptr1_v ret%sz = (ptr2_v - ptr1_v) * (size(arr, 3) - 1) ! for the last slice, take the actual offset, otherwise we imght go OOB ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr,3))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2)+1, lbound(arr,3))) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 2) end function function ext_acc_pass_4d_r8(arr) result(ret) use iso_fortran_env, only: real64 implicit none type(ext_acc_arr_desc) :: ret real(kind=real64), intent(in), target :: arr(:,:,:,:) type(c_ptr) :: ptr1, ptr2 integer(c_size_t) :: ptr1_v, ptr2_v ! get full slices for all but the last slice ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4)+1)) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%ptr = ptr1_v ret%sz = (ptr2_v - ptr1_v) * (size(arr, 4) - 1) ! for the last slice, take the actual offset, otherwise we imght go OOB ptr1 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3), lbound(arr,4))) ptr2 = c_loc(arr(lbound(arr,1), lbound(arr,2), lbound(arr, 3)+1, lbound(arr,4))) ptr1_v= transfer(ptr1, ptr1_v) ptr2_v= transfer(ptr2, ptr2_v) ret%sz = ret%sz + (ptr2_v - ptr1_v) * size(arr, 3) end function function get_common_pointers(in_ptrs, out_ptrs) result(num_ranges) implicit none type(ext_acc_arr_desc), intent(in) :: in_ptrs(:) type(common_pointer_descr), intent(out) :: out_ptrs(:) integer(c_size_t), allocatable :: ptrs_only(:) logical, allocatable :: mask(:) integer, allocatable :: sort_index(:) type(ext_acc_arr_desc), allocatable :: common_ptrs(:) integer :: i, j, num_ranges integer(c_size_t) :: start1, start2, end1, end2 logical :: found ! first sort the pointers increasingly such that no gaps are possible allocate(ptrs_only(size(in_ptrs))) do i = 1, size(in_ptrs) ptrs_only(i) = in_ptrs(i)%ptr enddo allocate(mask(size(in_ptrs))) do i = 1, size(in_ptrs) mask(i) = .true. enddo allocate(sort_index(size(in_ptrs))) do i = 1, size(in_ptrs) j = minloc(ptrs_only, 1, mask=mask) mask(j) = .false. sort_index(i) = j enddo ! initialize allocate(common_ptrs(size(in_ptrs))) do i = 1, size(in_ptrs) common_ptrs(1)%ptr = 0 common_ptrs(1)%sz = 0 enddo num_ranges = 1 common_ptrs(1) = in_ptrs(sort_index(1)) do i = 2, size(in_ptrs) found = .false. start1 = in_ptrs(sort_index(i))%ptr end1 = in_ptrs(sort_index(i))%ptr + in_ptrs(sort_index(i))%sz do j = 1, num_ranges start2 = common_ptrs(j)%ptr end2 = common_ptrs(j)%ptr + common_ptrs(j)%sz if (max(start1, start2) <= min(end1, end2)) then ! if we intersect with this range, extend the range common_ptrs(j)%ptr = min(start1, start2) common_ptrs(j)%sz = max(end1, end2) - common_ptrs(j)%ptr found = .true. exit endif enddo if (.not. found) then ! if we did not find anything: add a new one num_ranges = num_ranges + 1 common_ptrs(num_ranges)%ptr = start1 common_ptrs(num_ranges)%sz = end1 - start1 endif enddo do i = 1, num_ranges out_ptrs(i)%ptr = transfer(common_ptrs(i)%ptr, out_ptrs(i)%ptr) out_ptrs(i)%sz = common_ptrs(i)%sz enddo end function subroutine ext_acc_create(ptrs, stream) #ifdef ACCGPU use openacc, only: acc_async_sync #endif use iso_fortran_env, only: int32 implicit none type(ext_acc_arr_desc), intent(in) :: ptrs(:) #ifdef ACCGPU integer(acc_handle_kind), optional :: stream #endif #ifdef OMPGPU integer(kind=int32), optional :: stream #endif type(common_pointer_descr), allocatable :: common_ptrs(:) integer :: i, num_ranges integer(kind=int32), pointer :: pp(:) #ifdef ACCGPU integer(acc_handle_kind) :: stream_act if (present(stream)) then stream_act = stream else stream_act = acc_async_sync endif #endif allocate(common_ptrs(size(ptrs))) num_ranges = get_common_pointers(ptrs, common_ptrs) do i = 1, num_ranges call c_f_pointer(common_ptrs(i)%ptr, pp, [common_ptrs(i)%sz/c_sizeof(pp(1))]) #ifdef ACCGPU !$acc enter data create(pp) async(stream_act) #endif #ifdef OMPGPU !$omp target enter data map(alloc:pp) #endif enddo end subroutine subroutine ext_acc_copyin(ptrs, stream) #ifdef ACCGPU use openacc, only: acc_async_sync #endif use iso_fortran_env, only: int32 implicit none type(ext_acc_arr_desc), intent(in) :: ptrs(:) #ifdef ACCGPU integer(acc_handle_kind), optional :: stream #endif #ifdef OMPGPU integer(kind=int32), optional :: stream #endif type(common_pointer_descr), allocatable :: common_ptrs(:) integer :: i, num_ranges integer(kind=int32), pointer :: pp(:) #ifdef ACCGPU integer(acc_handle_kind) :: stream_act if (present(stream)) then stream_act = stream else stream_act = acc_async_sync endif #endif allocate(common_ptrs(size(ptrs))) num_ranges = get_common_pointers(ptrs, common_ptrs) do i = 1, num_ranges call c_f_pointer(common_ptrs(i)%ptr, pp, [common_ptrs(i)%sz/c_sizeof(pp(1))]) #ifdef ACCGPU !$acc enter data copyin(pp) async(stream_act) #endif #ifdef OMPGPU !$omp target enter data map(to:pp) #endif enddo end subroutine subroutine ext_acc_copyout(ptrs, stream) #ifdef ACCGPU use openacc, only: acc_async_sync #endif use iso_fortran_env, only: int32 implicit none type(ext_acc_arr_desc), intent(in) :: ptrs(:) #ifdef ACCGPU integer(acc_handle_kind), optional :: stream #endif #ifdef OMPGPU integer(kind=int32), optional :: stream #endif type(common_pointer_descr), allocatable :: common_ptrs(:) integer :: i, num_ranges integer(kind=int32), pointer :: pp(:) #ifdef ACCGPU integer(acc_handle_kind) :: stream_act if (present(stream)) then stream_act = stream else stream_act = acc_async_sync endif #endif allocate(common_ptrs(size(ptrs))) num_ranges = get_common_pointers(ptrs, common_ptrs) do i = 1, num_ranges call c_f_pointer(common_ptrs(i)%ptr, pp, [common_ptrs(i)%sz/c_sizeof(pp(1))]) #ifdef ACCGPU !$acc exit data copyout(pp) async(stream_act) #endif #ifdef OMPGPU !$omp target exit data map(from:pp) #endif enddo end subroutine subroutine ext_acc_delete(ptrs, stream) #ifdef ACCGPU use openacc, only: acc_async_sync #endif use iso_fortran_env, only: int32 implicit none type(ext_acc_arr_desc), intent(in) :: ptrs(:) #ifdef ACCGPU integer(acc_handle_kind), optional :: stream #else integer(kind=int32), optional :: stream #endif type(common_pointer_descr), allocatable :: common_ptrs(:) integer :: i, num_ranges integer(kind=int32), pointer :: pp(:) #ifdef ACCGPU integer(acc_handle_kind) :: stream_act if (present(stream)) then stream_act = stream else stream_act = acc_async_sync endif #endif allocate(common_ptrs(size(ptrs))) num_ranges = get_common_pointers(ptrs, common_ptrs) do i = 1, num_ranges call c_f_pointer(common_ptrs(i)%ptr, pp, [common_ptrs(i)%sz/c_sizeof(pp(1))]) #ifdef ACCGPU !$acc exit data delete(pp) async(stream_act) #endif #ifdef OMPGPU !$omp target exit data map(delete:pp) #endif enddo end subroutine end module ectrans-1.8.0/src/trans/gpu/algor/hicfft.h0000664000175000017500000000317515174631767020623 0ustar alastairalastair// (C) Copyright 2000- ECMWF. // // 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. // HIC--->FFT // hip // cuda // // Common header to provide abstraction layer to utilize hipfft and cufft from // common wrapper calls. Runtime and library specific implementations are pulled // in from bespoke header files. // #ifndef __HICFFT_H__ #define __HICFFT_H__ #include #include #include #include #include #include "abor1.h" #ifdef HIPGPU #include "hicfft_hip.h" #elif defined(CUDAGPU) #include "hicfft_cuda.h" #endif inline void _printError(const char * component, const char * file, const int line, int err, const char * err_str) { fprintf(stderr, "%s error at 1\n", component); fprintf(stderr, "%s error in file '%s'\n", component, file); fprintf(stderr, "%s error at 2\n", component); fprintf(stderr, "%s error line '%d'\n", component, line); fprintf(stderr, "%s error at 3\n", component); fprintf(stderr, "%s error %d: %s\nterminating!\n", component, err, err_str); return; } inline void __fftSafeCall(hipfftResult err, const char *file, const int line) { if( hipSuccess != (int) err) { _printError("GPU runtime", file, line, err, _fftGetErrorEnum(err)); std::ignore = hipDeviceReset(); ABOR1("Error in FFT\n"); } } #endif ectrans-1.8.0/src/trans/gpu/algor/seefmm_mix.F900000664000175000017500000003542615174631767021624 0ustar alastairalastair! (C) Copyright 2014- ECMWF. ! ! 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. ! module seefmm_mix !**** *SEEFMM_MIX* - Implementation of Simple Exponential Expansion FMM ! Purpose. ! -------- ! Implementation of Simple Exponential Expansion FMM !** Interface. ! ---------- ! Method. ! ------- ! Based on Algorithm described in Section 4 of the article ! "An improved fast multipole algorithm for potential fields on the line " ! Reference. ! ---------- ! "An improved fast multipole algorithm for potential fields on the line " ! by Norman Yarvin and Vladimir Rohklin, SIAM J. Numer. Anal. Vol. 36,No. 2,629-666. [1] ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2009-06-04 ! ------------------------------------------------------------------ use parkind_ectrans, only: jpim, jprbt, jprd use ecsort_mix, only: keysort use wts500_mod, only: wts500 private integer(kind=jpim) :: nfmm_lim=200 ! Appr. break-even limit for FMM integer(kind=jpim),parameter :: nquadEm14=28 ! Quadrature size for eps~=1.e-14 integer(kind=jpim),parameter :: nquadEm10=20! Quadrature size for eps~=1.e-10 integer(kind=jpim),parameter :: nquadEm07=14! Quadrature size for eps~=1.e-07 type fmm_type integer(kind=jpim) :: nxy ! Total number of point "nx+ny" integer(kind=jpim) :: nx ! Number of 'x' points integer(kind=jpim) :: nquad ! Quadrature N integer(kind=jpim) :: ncik ! Number of elem. in cik real(kind=JPRBT) :: rw(56) ! Quadrature weights real(kind=JPRBT) , pointer :: rdexp(:,:) ! exp(xy(i)-xy(i-1)) integer(kind=jpim), pointer :: index(:) ! index for sorted xy integer(kind=jpim), pointer :: nclose(:) ! No of "close" points real(kind=JPRBT) , pointer :: cik(:) ! Correction term (142 in [1]) end type fmm_type public :: fmm_type, setup_seefmm, free_seefmm, seefmm_mulm contains recursive subroutine setup_seefmm(kx,px,ky,py,ydfmm,pdiff) implicit none !**** *SETUP_SEEFMM* - Setup seefmm ! Purpose - Pre-computations for applying SEEFMM ! Explicit arguments : ! -------------------- ! kx - Number of x points ! px - x points ! ky - Number of y points ! py - y points ! ydfmm - result of pre-computations ! pdiff - difference matrix (optional) integer(kind=jpim),intent(in) :: kx real(kind=jprd) ,intent(in) :: px(:) integer(kind=jpim),intent(in) :: ky real(kind=jprd) ,intent(in) :: py(:) type(fmm_type) ,intent(out) :: ydfmm real(kind=jprd),optional,intent(in) :: pdiff(:,:) real(kind=jprd) :: zxy(kx+ky), zcik((kx+ky)*(kx+ky)) real(kind=jprd) :: zr, zrt(56), zrw(56) real(kind=jprd), allocatable :: zrdexp(:,:) integer(kind=jpim) :: ixy !--------------------------------------------------------------------------- ydfmm%nx=kx ixy=kx+ky ydfmm%nxy=ixy allocate(ydfmm%index(ixy)) !ydfmm%nquad=nquadEm14 !Set precicion to 1.E-14 ydfmm%nquad=nquadEm07 !Set precicion to 1.E-07 ! Combine px and py to form xxy, compute ascending index for xxy call comb_xy(kx,px,ky,py,ixy,zxy,ydfmm%index) ! Setup quadrature, scale (see 3.1.1 in [1]) call suquad(ixy,zxy(ydfmm%index(1))-zxy(ydfmm%index(ixy)),ydfmm%nquad,& & zrw,zrt,zr) allocate(zrdexp(ydfmm%nquad,ixy)) allocate(ydfmm%nclose(ixy)) ! Main pre-computation call prepotf(kx,ixy,ydfmm%nquad,zrw,zrt,zr,zxy,ydfmm%index,& & zrdexp,ydfmm%nclose,zcik,ydfmm%ncik,pdiff) allocate(ydfmm%rdexp(ydfmm%nquad,ixy)) allocate(ydfmm%cik(ydfmm%ncik)) ydfmm%rw(:) = real(zrw(:),JPRBT) ydfmm%rdexp(:,:) = real(zrdexp(:,:),JPRBT) ydfmm%cik(:) = real(zcik(1:ydfmm%ncik),JPRBT) end subroutine setup_seefmm !========================================================================== subroutine free_seefmm(ydfmm) implicit none !**** *FREE_SEEFMM* - Release memory ! Purpose - Release memory used by ydfmm ! Explicit arguments : ! -------------------- ! ydfmm - result of pre-computations type(fmm_type) ,intent(inout) :: ydfmm deallocate(ydfmm%index) deallocate(ydfmm%rdexp) deallocate(ydfmm%nclose) deallocate(ydfmm%cik) end subroutine free_seefmm !========================================================================== recursive subroutine potf(kn,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclosel,kcik,pcik,ptheta) implicit none integer(kind=jpim),intent(in) :: kn integer(kind=jpim),intent(in) :: kx logical ,intent(in) :: ldxout integer(kind=jpim),intent(in) :: kquad real(kind=JPRBT) ,intent(in) :: prw(:) real(kind=JPRBT) ,intent(in) :: pq(:) real(kind=JPRBT) ,intent(in) :: prdexp(:,:) integer(kind=jpim),intent(in) :: kindex(:) integer(kind=jpim),intent(in) :: kclosel(:) integer(kind=jpim),intent(in) :: kcik real(kind=JPRBT) ,intent(in) :: pcik(:) real(kind=JPRBT) ,intent(out) :: ptheta(:) real(kind=JPRBT) :: zalpha(kquad),zq(kn),ztheta(kn) integer(kind=jpim) :: j1,j2,jm,inumc,idist,iquad integer(kind=jpim) :: iout,iq,i1,i1p1,i1pd,ik1,ix,iy logical :: lxy,llxy(kn) lxy(ik1) = (ik1 <= kx .eqv. ldxout) !------------------------------------------------------------------------- ztheta(:)=0.0_JPRBT if(ldxout) then ix=0 iy=-kx else ix=-kx iy=0 endif do j1=1,kn i1=kindex(j1) llxy(j1)=lxy(i1) if(llxy(j1)) then zq(j1)=pq(kindex(j1)+ix) else zq(j1)=0.0_JPRBT endif enddo zalpha(:)=zq(1) do j1=2,kn if(llxy(j1)) then do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1)+zq(j1) enddo else do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1) ztheta(j1)=ztheta(j1)+prw(jm)*zalpha(jm) enddo endif enddo zalpha(1:kquad)=zq(kn) do j1=kn-1,1,-1 if(llxy(j1)) then do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1+1)+zq(j1) enddo else do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1+1) ztheta(j1)=ztheta(j1)-prw(jm)*zalpha(jm) enddo endif enddo IF(kcik > 0) then inumc=0 do j1=1,kn-1 do j2=1,kclosel(j1) idist=j2 if(.not.llxy(j1) .and. llxy(j1+idist)) then inumc=inumc+1 ztheta(j1)=ztheta(j1)-pcik(inumc)*zq(j1+idist) elseif(llxy(j1) .and. .not.llxy(j1+idist)) then inumc=inumc+1 ztheta(j1+idist)=ztheta(j1+idist)+pcik(inumc)*zq(j1) endif enddo enddo endif do j1=1,kn if(.not. llxy(j1)) then i1=kindex(j1) ptheta(i1+iy)=ztheta(j1) endif enddo end subroutine potf !========================================================================== recursive subroutine seefmm_mulv(ydfmm,ldxout,pq,ptheta) implicit none type(fmm_type) ,intent(in) :: ydfmm logical ,intent(in) :: ldxout real(kind=JPRBT) ,intent(in) :: pq(:) real(kind=JPRBT) ,intent(out) :: ptheta(:) !------------------------------------------------------------------------- call potf(ydfmm%nxy,ydfmm%nx,ldxout,ydfmm%nquad,& & ydfmm%rw,pq,ydfmm%rdexp,ydfmm%index,& & ydfmm%nclose,ydfmm%ncik,ydfmm%cik,ptheta) end subroutine seefmm_mulv !========================================================================== recursive subroutine seefmm_mulm(ydfmm,km,kskip,ldxout,pq,ptheta) implicit none type(fmm_type) ,intent(in) :: ydfmm integer(kind=jpim),intent(in) :: km integer(kind=jpim),intent(in) :: kskip logical ,intent(in) :: ldxout real(kind=JPRBT) ,intent(in) :: pq(:,:) real(kind=JPRBT) ,intent(out) :: ptheta(:,:) !------------------------------------------------------------------------- call potfm(ydfmm%nxy,km,kskip,ydfmm%nx,ldxout,ydfmm%nquad,& & ydfmm%rw,pq,ydfmm%rdexp,ydfmm%index,& & ydfmm%nclose,ydfmm%ncik,ydfmm%cik,ptheta) end subroutine seefmm_mulm !========================================================================== recursive subroutine potfm(kn,km,kskip,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclosel,kcik,pcik,ptheta) implicit none integer(kind=jpim),intent(in) :: kn integer(kind=jpim),intent(in) :: km integer(kind=jpim),intent(in) :: kskip integer(kind=jpim),intent(in) :: kx logical ,intent(in) :: ldxout integer(kind=jpim),intent(in) :: kquad real(kind=JPRBT) ,intent(in) :: prw(:) real(kind=JPRBT) ,intent(in) :: pq(:,:) real(kind=JPRBT) ,intent(in) :: prdexp(:,:) integer(kind=jpim),intent(in) :: kindex(:) integer(kind=jpim),intent(in) :: kclosel(:) integer(kind=jpim),intent(in) :: kcik real(kind=JPRBT) ,intent(in) :: pcik(:) real(kind=JPRBT) ,intent(out) :: ptheta(:,:) real(kind=JPRBT) :: zalpha(kquad,km) integer(kind=jpim) :: j1,j2,jm,jq,inumc,idist,iquad integer(kind=jpim) :: iout,iq,i1,i1p1,i1pd,ik1,ix,iy logical :: lxy,llxy(kn) lxy(ik1) = (ik1 <= kx .eqv. ldxout) !------------------------------------------------------------------------- !CALL GSTATS(209,0) ptheta(:,:)=0.0_JPRBT if(ldxout) then ix=0 iy=-kx else ix=-kx iy=0 endif do j1=1,kn i1=kindex(j1) llxy(j1)=lxy(i1) enddo if(llxy(1)) then do jm=1,km,kskip zalpha(:,jm)=pq(jm,kindex(1)+ix) enddo else zalpha(:,:)=0.0_JPRBT endif !CALL GSTATS(209,1) !CALL GSTATS(210,0) do j1=2,kn i1=kindex(j1) if(llxy(j1) ) then if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo endif else if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)+prw(jq)*zalpha(jq,jm) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)+prw(jq)*zalpha(jq,jm) enddo enddo endif endif enddo !CALL GSTATS(210,1) !CALL GSTATS(211,0) if(llxy(kn)) then do jm=1,km,kskip zalpha(:,jm)=pq(jm,kindex(kn)+ix) enddo else zalpha(:,:)=0.0 endif !CALL GSTATS(211,1) !CALL GSTATS(212,0) do j1=kn-1,1,-1 i1=kindex(j1) i1p1=kindex(j1+1) if(llxy(j1)) then if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo endif else if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)-prw(jq)*zalpha(jq,jm) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)-prw(jq)*zalpha(jq,jm) enddo enddo endif endif enddo !CALL GSTATS(212,1) IF(kcik > 0) then ! CALL GSTATS(213,0) inumc=0 do j1=1,kn-1 do j2=1,kclosel(j1) idist=j2 i1=kindex(j1) i1pd=kindex(j1+idist) if(.not.llxy(j1) .and. llxy(j1+idist)) then inumc=inumc+1 do jm=1,km,kskip ptheta(jm,i1+iy)=ptheta(jm,i1+iy)-pcik(inumc)*pq(jm,i1pd+ix) enddo elseif(llxy(j1) .and. .not.llxy(j1+idist)) then inumc=inumc+1 do jm=1,km,kskip ptheta(jm,i1pd+iy)=ptheta(jm,i1pd+iy)+pcik(inumc)*pq(jm,i1+ix) enddo endif enddo enddo ! CALL GSTATS(213,1) endif end subroutine potfm !========================================================================= recursive subroutine suquad(kn,prange,kquad,prw,prt,pr) implicit none integer(kind=jpim) ,intent(in) :: kn real(kind=jprd),intent(in) :: prange integer(kind=jpim) ,intent(in) :: kquad real(kind=jprd),intent(out) :: prw(:) real(kind=jprd),intent(out) :: prt(:) real(kind=jprd),intent(out) :: pr real(kind=jprd) :: za,zb,zs integer(kind=jpim) :: jm !------------------------------------------------------------------------- za=1.0_jprd zb=500.0_jprd zs=zb/prange pr=za/zs call wts500(prt,prw,kquad) do jm=1,kquad prw(jm)=prw(jm)*zs prt(jm)=prt(jm)*zs enddo end subroutine suquad !========================================================================== recursive subroutine comb_xy(kx,px,ky,py,kxy,pxy,kindex) implicit none integer(kind=jpim), intent(in) :: kx,ky real(kind=jprd), intent(in) :: px(:) real(kind=jprd), intent(in) :: py(:) integer(kind=jpim), intent(in) :: kxy real(kind=jprd), intent(out) :: pxy(:) integer(kind=jpim), intent(out) :: kindex(:) integer(kind=jpim) :: iret !------------------------------------------------------------------------- pxy(1:kx)=px(1:kx) pxy(kx+1:kx+ky)=py(1:ky) call keysort(iret,pxy,kxy,descending=.true.,index=kindex,init=.true.) end subroutine comb_xy !========================================================================== recursive subroutine prepotf(kx,kxy,kquad,prw,prt,pr,pxy,kindex,prdexp,& & kclosel,pcik,knocik,pdiff) implicit none integer(kind=jpim), intent(in) :: kx integer(kind=jpim), intent(in) :: kxy integer(kind=jpim), intent(in) :: kquad real(kind=jprd), intent(in) :: pxy(:) real(kind=jprd), intent(in) :: prw(:) real(kind=jprd), intent(in) :: pr real(kind=jprd), intent(in) :: prt(:) integer(kind=jpim), intent(in) :: kindex(:) real(kind=jprd), intent(out) :: prdexp(:,:) integer(kind=jpim), intent(out) :: kclosel(:) real(kind=jprd), intent(out) :: pcik(:) integer(kind=jpim), intent(out) :: knocik real(kind=jprd),optional, intent(in) :: pdiff(:,:) real(kind=jprd) :: zdx real(kind=jprd) :: zsum real(kind=jprd) :: zdiff(kxy,kxy) integer(kind=jpim) :: jxy,jq,isize,jdist,ixy,ixym1,i1,i1pd,j1,j2 logical :: llexit !------------------------------------------------------------------------- if(present(pdiff)) then zdiff(:,:)=pdiff(:,:) else do j1=1,kxy do j2=1,kxy zdiff(j1,j2)=pxy(j1)-pxy(j2) enddo enddo endif do jxy=2,kxy ixy=kindex(jxy) ixym1=kindex(jxy-1) do jq=1,kquad prdexp(jq,jxy)=exp(zdiff(ixy,ixym1)*prt(jq)) enddo enddo kclosel(:)=0 knocik=0 isize=size(pcik) llexit=.true. do jxy=1,kxy-1 do jdist=1,kxy-jxy i1=kindex(jxy) i1pd=kindex(jxy+jdist) zdx=zdiff(i1,i1pd) if(zdx < pr) then llexit=.false. kclosel(jxy)=kclosel(jxy)+1 if((i1 > kx .and. i1pd <= kx) .or. (i1pd > kx .and. i1 <= kx)) then knocik=knocik+1 zsum=0.0_jprd do jq=1,kquad zsum=zsum+prw(jq)*exp(-zdx*prt(jq)) enddo pcik(knocik)=1.0_jprd/zdx-zsum endif else exit endif enddo if(knocik > isize) stop ' precompfint : pcik tto small' enddo end subroutine prepotf !========================================================================== end module seefmm_mix ectrans-1.8.0/src/trans/gpu/algor/hicblas_mod.F900000664000175000017500000001030715174631767021726 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! ! 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. ! MODULE HICBLAS_MOD IMPLICIT NONE INTERFACE SUBROUTINE HIP_DGEMM_BATCHED( & & CTA, CTB, & & M, N, K, & & ALPHA, & & A, LDA, TDA, & & B, LDB, TDB, & & BETA, & & C, LDC, TDC, & & BATCHCOUNT, STREAM, ALLOC & &) BIND(C, NAME='hipblas_dgemm_wrapper') USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_DOUBLE, C_SIZE_T, C_PTR CHARACTER(1,C_CHAR), VALUE :: CTA, CTB INTEGER(C_INT), VALUE :: M, N, K, LDA, LDB, LDC, TDA, TDB, TDC, BATCHCOUNT REAL(C_DOUBLE), VALUE :: ALPHA,BETA TYPE(C_PTR), INTENT(IN), VALUE :: A TYPE(C_PTR), INTENT(IN), VALUE :: B TYPE(C_PTR), INTENT(IN), VALUE :: C INTEGER(KIND=C_SIZE_T) :: STREAM TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE HIP_DGEMM_BATCHED SUBROUTINE HIP_SGEMM_BATCHED( & & CTA, CTB, & & M, N, K, & & ALPHA, & & A, LDA, TDA, & & B, LDB, TDB, & & BETA, & & C, LDC, TDC, & & BATCHCOUNT, STREAM, ALLOC & &) BIND(C, NAME='hipblas_sgemm_wrapper') USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_SIZE_T, C_PTR CHARACTER(1,C_CHAR), VALUE :: CTA, CTB INTEGER(C_INT), VALUE :: M, N, K, LDA, LDB, LDC, TDA, TDB, TDC, BATCHCOUNT REAL(C_FLOAT), VALUE :: ALPHA, BETA TYPE(C_PTR), INTENT(IN), VALUE :: A TYPE(C_PTR), INTENT(IN), VALUE :: B TYPE(C_PTR), INTENT(IN), VALUE :: C INTEGER(KIND=C_SIZE_T) :: STREAM TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE HIP_SGEMM_BATCHED END INTERFACE INTERFACE SUBROUTINE CLEAN_GEMM(RESOL_ID) BIND(C, NAME="clean_gemm") USE ISO_C_BINDING INTEGER(KIND=C_INT), INTENT(IN), VALUE :: RESOL_ID END SUBROUTINE END INTERFACE INTERFACE SUBROUTINE HIP_DGEMM_GROUPED( & & RESOL_ID, BLAS_ID, CTA, CTB, & & M, N, K, & & ALPHA, & & A, LDA, OFFSETA, & & B, LDB, OFFSETB, & & BETA, & & C, LDC, OFFSETC, & & BATCHCOUNT, STREAM, ALLOC & &) BIND(C, NAME='hipblas_dgemm_wrapper_grouped') USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_DOUBLE, C_SIZE_T, C_PTR, C_INT64_T CHARACTER(1,C_CHAR), VALUE :: CTA, CTB INTEGER(C_INT), VALUE :: RESOL_ID, BLAS_ID, M, LDA, LDC, BATCHCOUNT INTEGER(C_INT) :: N(*), K(*), LDB(*) INTEGER(C_INT64_T) :: OFFSETA(*), OFFSETB(*), OFFSETC(*) REAL(C_DOUBLE), VALUE :: ALPHA,BETA TYPE(C_PTR), INTENT(IN), VALUE :: A TYPE(C_PTR), INTENT(IN), VALUE :: B TYPE(C_PTR), INTENT(IN), VALUE :: C INTEGER(KIND=C_SIZE_T) :: STREAM TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE HIP_DGEMM_GROUPED SUBROUTINE HIP_SGEMM_GROUPED( & & RESOL_ID, BLAS_ID, CTA, CTB, & & M, N, K, & & ALPHA, & & A, LDA, OFFSETA, & & B, LDB, OFFSETB, & & BETA, & & C, LDC, OFFSETC, & & BATCHCOUNT, STREAM, ALLOC & &) BIND(C, NAME='hipblas_sgemm_wrapper_grouped') USE ISO_C_BINDING, ONLY: C_CHAR, C_INT, C_FLOAT, C_SIZE_T, C_PTR, C_INT64_T CHARACTER(1,C_CHAR), VALUE :: CTA, CTB INTEGER(C_INT), VALUE :: RESOL_ID, BLAS_ID, M, LDA, LDC, BATCHCOUNT INTEGER(C_INT) :: N(*), K(*), LDB(*) INTEGER(C_INT64_T) :: OFFSETA(*), OFFSETB(*), OFFSETC(*) REAL(C_FLOAT), VALUE :: ALPHA,BETA TYPE(C_PTR), INTENT(IN), VALUE :: A TYPE(C_PTR), INTENT(IN), VALUE :: B TYPE(C_PTR), INTENT(IN), VALUE :: C INTEGER(KIND=C_SIZE_T) :: STREAM TYPE(C_PTR), INTENT(IN), VALUE :: ALLOC END SUBROUTINE HIP_SGEMM_GROUPED END INTERFACE END MODULE HICBLAS_MOD ectrans-1.8.0/src/trans/gpu/algor/growing_allocator_mod.F900000664000175000017500000000741315174631767024041 0ustar alastairalastairMODULE GROWING_ALLOCATOR_MOD USE ISO_C_BINDING, ONLY: C_INT8_T PRIVATE PUBLIC :: GROWING_ALLOCATION_TYPE PUBLIC :: REALLOCATE_GROWING_ALLOCATION, REGISTER_FREE_FUNCTION PUBLIC :: DESTROY_GROWING_ALLOCATOR ABSTRACT INTERFACE SUBROUTINE FREE_FUNC_PROC(PTR, SZ) BIND(C) USE ISO_C_BINDING, ONLY: C_SIZE_T, C_INT8_T IMPLICIT NONE INTEGER(KIND=C_INT8_T), TARGET :: PTR(:) INTEGER(C_SIZE_T), VALUE :: SZ END SUBROUTINE END INTERFACE TYPE FREE_FUNC_TYPE PROCEDURE(FREE_FUNC_PROC), POINTER, NOPASS :: FUNC => NULL () END TYPE TYPE GROWING_ALLOCATION_TYPE INTEGER(KIND=C_INT8_T), POINTER :: PTR(:) TYPE(FREE_FUNC_TYPE) :: FREE_FUNCS(10) INTEGER :: FREE_FUNCS_SZ END TYPE CONTAINS SUBROUTINE REALLOCATE_GROWING_ALLOCATION(ALLOC, SZ) #ifdef OMPGPU USE OMP_LIB, ONLY: OMP_GET_DEFAULT_DEVICE, OMP_TARGET_ALLOC, OMP_TARGET_ASSOCIATE_PTR #endif USE ISO_C_BINDING, ONLY: C_SIZE_T, C_PTR, C_F_POINTER, C_LOC USE TPM_GEN, ONLY: NOUT IMPLICIT NONE TYPE(GROWING_ALLOCATION_TYPE), INTENT(INOUT) :: ALLOC INTEGER(C_SIZE_T), INTENT(IN) :: SZ #ifdef OMPGPU TYPE(C_PTR) :: DEV_PTR INTEGER :: DEVICE_NUM, IERR #endif ! Deallocate existing pointer IF (ASSOCIATED(ALLOC%PTR) .AND. SZ > SIZE(ALLOC%PTR, 1, C_SIZE_T)) THEN WRITE(NOUT,*) "WARNING: REALLOCATING GROWING POINTER CAUSING GRAPH REINSTANTIATION" CALL DESTROY_GROWING_ALLOCATOR(ALLOC) ENDIF IF (.NOT. ASSOCIATED(ALLOC%PTR)) THEN #ifdef OMPGPU DEVICE_NUM = OMP_GET_DEFAULT_DEVICE() DEV_PTR = OMP_TARGET_ALLOC(SZ, DEVICE_NUM) CALL C_F_POINTER(DEV_PTR, ALLOC%PTR, [SZ]) IERR = OMP_TARGET_ASSOCIATE_PTR(C_LOC(ALLOC%PTR), DEV_PTR, SZ, 0_C_SIZE_T, DEVICE_NUM) #endif #ifdef ACCGPU ALLOCATE(ALLOC%PTR(SZ)) !$ACC ENTER DATA CREATE(ALLOC%PTR) #endif ALLOC%FREE_FUNCS_SZ = 0 ENDIF END SUBROUTINE SUBROUTINE REGISTER_FREE_FUNCTION(ALLOC, FREE_FUNC) USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS IMPLICIT NONE TYPE(GROWING_ALLOCATION_TYPE) :: ALLOC PROCEDURE(FREE_FUNC_PROC) :: FREE_FUNC INTEGER :: I DO I = 1, ALLOC%FREE_FUNCS_SZ IF (ASSOCIATED(ALLOC%FREE_FUNCS(I)%FUNC, FREE_FUNC)) & RETURN ENDDO ALLOC%FREE_FUNCS_SZ = ALLOC%FREE_FUNCS_SZ + 1 IF (ALLOC%FREE_FUNCS_SZ > SIZE(ALLOC%FREE_FUNCS)) THEN CALL ABORT_TRANS("REGISTER_FREE_FUNCTION: ERROR - Too many free functions registered") ENDIF ALLOC%FREE_FUNCS(ALLOC%FREE_FUNCS_SZ)%FUNC => FREE_FUNC END SUBROUTINE SUBROUTINE REGISTER_FREE_C(ALLOC_C, FREE_FUNC_C) BIND(C, NAME="growing_allocator_register_free_c") USE ISO_C_BINDING, ONLY: C_FUNPTR, C_PTR, C_F_PROCPOINTER, C_F_POINTER IMPLICIT NONE TYPE(C_PTR), VALUE :: ALLOC_C TYPE(C_FUNPTR), VALUE :: FREE_FUNC_C TYPE(GROWING_ALLOCATION_TYPE), POINTER :: ALLOC PROCEDURE(FREE_FUNC_PROC), POINTER :: FREE_FUNC CALL C_F_POINTER(ALLOC_C, ALLOC) CALL C_F_PROCPOINTER(FREE_FUNC_C, FREE_FUNC) CALL REGISTER_FREE_FUNCTION(ALLOC, FREE_FUNC) END SUBROUTINE SUBROUTINE DESTROY_GROWING_ALLOCATOR(ALLOC) #ifdef OMPGPU USE OMP_LIB, ONLY: OMP_GET_DEFAULT_DEVICE, OMP_TARGET_FREE #endif USE ISO_C_BINDING, ONLY: C_SIZE_T, C_LOC IMPLICIT NONE TYPE(GROWING_ALLOCATION_TYPE) :: ALLOC INTEGER :: I #ifdef OMPGPU INTEGER :: DEVICE_NUM #endif IF (ASSOCIATED(ALLOC%PTR)) THEN DO I = 1, ALLOC%FREE_FUNCS_SZ CALL ALLOC%FREE_FUNCS(I)%FUNC(ALLOC%PTR, & SIZE(ALLOC%PTR, 1, C_SIZE_T)) ENDDO #ifdef OMPGPU DEVICE_NUM = OMP_GET_DEFAULT_DEVICE() CALL OMP_TARGET_FREE(C_LOC(ALLOC%PTR), DEVICE_NUM) #endif #ifdef ACCGPU !$ACC EXIT DATA DELETE(ALLOC%PTR) DEALLOCATE(ALLOC%PTR) #endif NULLIFY(ALLOC%PTR) ENDIF END SUBROUTINE END MODULE ectrans-1.8.0/src/trans/gpu/algor/hicblas_cutlass.cuda.h0000664000175000017500000002364115174631767023436 0ustar alastairalastair// (C) Copyright 2000- ECMWF. // (C) Copyright 2024- NVIDIA. #ifdef USE_CUTLASS //#include "hicblas.h" #include "cutlass/gemm/device/gemm.h" #define CUTLASS_CHECK(e) \ { \ cutlass::Status err = (e); \ if (err != cutlass::Status::kSuccess) { \ fprintf(stderr, "CUTLASS error: %s, line %d, %s: %i\n", __FILE__, \ __LINE__, #e, (int)err); \ exit(EXIT_FAILURE); \ } \ } #ifdef USE_CUTLASS_3XTF32 constexpr bool use_3xtf32 = true; #else constexpr bool use_3xtf32 = false; #endif template CutlassGemm &get_cutlass_handle() { static auto handle = std::make_unique(); return *handle; } namespace detail { enum class CutlassType { cutlass_3xtf32, cutlass_fp32 }; template class cutlass_sgemm_grouped; template class cutlass_sgemm_grouped { // this was verified using Ampere and uses 3XTF32 static constexpr int AlignmentA = 4; static constexpr int AlignmentB = 4; using ThreadblockShape = cutlass::gemm::GemmShape<128, 64, 32>; using WarpShape = cutlass::gemm::GemmShape<64, 32, 32>; using InstructionShape = cutlass::gemm::GemmShape<16, 8, 8>; using OperatorClass = cutlass::arch::OpClassTensorOp; using MyOp = cutlass::arch::OpMultiplyAddFastF32; using Gemm = cutlass::gemm::device::Gemm< float, std::conditional_t, // float, std::conditional_t, // float, cutlass::layout::ColumnMajor, // float, // OperatorClass, cutlass::arch::Sm80, // ThreadblockShape, WarpShape, InstructionShape, // cutlass::epilogue::thread::LinearCombination< // float, // 128 / cutlass::sizeof_bits::value, float, // float // >, // cutlass::gemm::threadblock::GemmIdentityThreadblockSwizzle<>, // 3, // AlignmentA, // AlignmentB, // true, // MyOp // >; // Note that when setting this alignment > 1 the inputs must be properly // zero padded, otherwise NaNs might propagate. static constexpr int sz_align = 8; public: using real_type = float; void operator()(cudaStream_t stream, int m, int n, int k, float alpha, const float *A, int lda, const float *B, int ldb, float beta, float *C, int ldc) const { auto &gemm_op = get_cutlass_handle(); CUTLASS_CHECK(gemm_op( {// {(m + sz_align - 1) / sz_align * sz_align, (n + sz_align - 1) / sz_align * sz_align, (k + sz_align - 1) / sz_align * sz_align}, {const_cast(A), lda}, {const_cast(B), ldb}, {C, ldc}, {C, ldc}, {alpha, beta}}, nullptr, stream)); } }; template class cutlass_sgemm_grouped { // this was verified using Volta and uses FP32 static constexpr int AlignmentA = 1; static constexpr int AlignmentB = 1; using ThreadblockShape = cutlass::gemm::GemmShape<128, 128, 8>; using WarpShape = cutlass::gemm::GemmShape<32, 32, 8>; using InstructionShape = cutlass::gemm::GemmShape<1, 1, 1>; using OperatorClass = cutlass::arch::OpClassSimt; using MyOp = cutlass::arch::OpMultiplyAdd; using Gemm = cutlass::gemm::device::Gemm< float, // std::conditional_t, // float, // std::conditional_t, // float, cutlass::layout::ColumnMajor, // float, // OperatorClass, cutlass::arch::Sm70, // ThreadblockShape, WarpShape, InstructionShape, // cutlass::epilogue::thread::LinearCombination< // float, // 1, // float, // float // >, // cutlass::gemm::threadblock::GemmIdentityThreadblockSwizzle<>, // 2, // AlignmentA, // AlignmentB, // true, // MyOp // >; // Note that when setting this alignment > 1 the inputs must be properly // zero padded, otherwise NaNs might propagate. static constexpr int sz_align = 1; public: using real_type = float; void operator()(cudaStream_t stream, int m, int n, int k, float alpha, const float *A, int lda, const float *B, int ldb, float beta, float *C, int ldc) const { auto &gemm_op = get_cutlass_handle(); CUTLASS_CHECK(gemm_op( {// {(m + sz_align - 1) / sz_align * sz_align, (n + sz_align - 1) / sz_align * sz_align, (k + sz_align - 1) / sz_align * sz_align}, {const_cast(A), lda}, {const_cast(B), ldb}, {C, ldc}, {C, ldc}, {alpha, beta}}, nullptr, stream)); } }; } // namespace detail template void cutlass_sgemm_wrapper_grouped_op(int resol_id, int blas_id, int m, const int *n, const int *k, float alpha, const float *A, int lda, const int64_t *offsetsA, const float *B, const int *ldb, const int64_t *offsetsB, float beta, float *C, int ldc, const int64_t *offsetsC, int batchCount, cudaStream_t stream, void *growing_allocator) { using namespace detail; int device; HIC_CHECK(cudaGetDevice(&device)); int capability_major; HIC_CHECK(cudaDeviceGetAttribute(&capability_major, cudaDevAttrComputeCapabilityMajor, device)); if (capability_major >= 8 && use_3xtf32) run_group_graph(cutlass_sgemm_grouped(), resol_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, blas_id, growing_allocator); else run_group_graph(cutlass_sgemm_grouped(), resol_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, blas_id, growing_allocator); } void cutlass_sgemm_wrapper_grouped(int resol_id, int blas_id, char transa, char transb, int m, const int *n, const int *k, float alpha, const float *A, int lda, const int64_t *offsetsA, const float *B, const int *ldb, const int64_t *offsetsB, float beta, float *C, int ldc, const int64_t *offsetsC, int batchCount, cudaStream_t stream, void *growing_allocator) { if (transa == 'N' && transb == 'N') cutlass_sgemm_wrapper_grouped_op( resol_id, blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, growing_allocator); else if (transa == 'N' && transb == 'T') cutlass_sgemm_wrapper_grouped_op( resol_id, blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, growing_allocator); else if (transa == 'T' && transb == 'N') cutlass_sgemm_wrapper_grouped_op( resol_id, blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, growing_allocator); else if (transa == 'T' && transb == 'T') cutlass_sgemm_wrapper_grouped_op( resol_id, blas_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, growing_allocator); else assert(false); } //} #endif ectrans-1.8.0/src/trans/gpu/algor/hicfft.hip.cpp0000664000175000017500000002473515174631767021742 0ustar alastairalastair#include "hicfft.h" #include #include #include "growing_allocator.h" #define fftSafeCall(err) __fftSafeCall(err, __FILE__, __LINE__) // __global__ void debug(int varId, int N, HIP_DATA_TYPE_COMPLEX *x) { // for (int i = 0; i < N; i++) // { // HIP_DATA_TYPE_COMPLEX a = x[i]; // double b = (double)a.x; // double c = (double)a.y; // if (varId == 0) printf("GPU: input[%d]=(%2.4f,%2.4f)\n",i+1,b,c); // if (varId == 1) printf("GPU: output[%d]=(%2.4f,%2.4f)\n",i+1,b,c); // } // } // __global__ void debugFloat(int varId, int N, HIP_DATA_TYPE_REAL *x) { // for (int i = 0; i < N; i++) // { // double a = (double)x[i]; // if (varId == 0) printf("GPU: input[%d]=%2.4f\n",i+1,a); // if (varId == 1) printf("GPU: output[%d]=%2.4f\n",i+1,a); // } // } namespace { struct Double { using real = double; using cmplx = hipfftDoubleComplex; }; struct Float { using real = float; using cmplx = hipfftComplex; }; template class hicfft_plan { using real = typename Type::real; using cmplx = typename Type::cmplx; public: void exec(real *data_real, cmplx *data_complex) const { real *data_real_l = &data_real[offset]; cmplx *data_complex_l = &data_complex[offset / 2]; if constexpr (Direction == HIPFFT_R2C) fftSafeCall(hipfftExecR2C(*handle_ptr, data_real_l, data_complex_l)); else if constexpr (Direction == HIPFFT_C2R) fftSafeCall(hipfftExecC2R(*handle_ptr, data_complex_l, data_real_l)); else if constexpr (Direction == HIPFFT_D2Z) fftSafeCall(hipfftExecD2Z(*handle_ptr, data_real_l, data_complex_l)); else if constexpr (Direction == HIPFFT_Z2D) fftSafeCall(hipfftExecZ2D(*handle_ptr, data_complex_l, data_real_l)); } void set_stream(hipStream_t stream) { fftSafeCall(hipfftSetStream(*handle_ptr, stream)); } hicfft_plan(hipfftHandle handle_, int64_t offset_) : handle_ptr(new hipfftHandle{handle_}, [](auto ptr) { fftSafeCall(hipfftDestroy(*ptr)); delete ptr; }), offset(offset_) {} private: std::shared_ptr handle_ptr; int64_t offset; }; struct cache_key { int resol_id; int kfield; bool operator==(const cache_key &other) const { return resol_id == other.resol_id && kfield == other.kfield; } cache_key(int resol_id_, int kfield_) : resol_id(resol_id_), kfield(kfield_) {} }; } // namespace template <> struct std::hash { std::size_t operator()(const cache_key &k) const { return k.resol_id * 10000 + k.kfield; } }; namespace { // kfield -> handles template auto &get_fft_plan_cache() { static std::unordered_map>> fftPlansCache; return fftPlansCache; } // kfield -> graphs template auto &get_graph_cache() { static std::unordered_map> graphCache; return graphCache; } // kfield -> ptrs template auto &get_ptr_cache() { using real = typename Type::real; using cmplx = typename Type::cmplx; static std::unordered_map> ptrCache; return ptrCache; } template void free_fft_graph_cache(float *, size_t) { get_graph_cache().clear(); get_ptr_cache().clear(); } template void erase_resol_from_cache(Cache &cache, int resol_id) { // Note that in C++20 this could also be std::erase_if int erased = 0; for (auto it = cache.begin(); it != cache.end();) { if (it->first.resol_id == resol_id) { it = cache.erase(it); ++erased; } else ++it; } } template void erase_from_caches(int resol_id) { erase_resol_from_cache(get_fft_plan_cache(), resol_id); erase_resol_from_cache(get_graph_cache(), resol_id); erase_resol_from_cache(get_ptr_cache(), resol_id); } template std::vector> plan_all(int resol_id, int kfield, int *loens, int nfft, int64_t *offsets) { static constexpr bool is_forward = Direction == HIPFFT_R2C || Direction == HIPFFT_D2Z; auto key = cache_key{resol_id, kfield}; auto &fftPlansCache = get_fft_plan_cache(); auto fftPlans = fftPlansCache.find(key); if (fftPlans == fftPlansCache.end()) { // the fft plans do not exist yet std::vector> newPlans; newPlans.reserve(nfft); for (int i = 0; i < nfft; ++i) { int nloen = loens[i]; hipfftHandle plan; int dist = offsets[i + 1] - offsets[i]; int embed[] = {1}; fftSafeCall(hipfftPlanMany( &plan, 1, &nloen, embed, 1, is_forward ? dist : dist / 2, embed, 1, is_forward ? dist / 2 : dist, Direction, abs(kfield))); newPlans.emplace_back(plan, abs(kfield) * offsets[i]); } fftPlansCache.insert({key, newPlans}); } return fftPlansCache.find(key)->second; } template void run_group_graph(typename Type::real *data_real, typename Type::cmplx *data_complex, int resol_id, int kfield, int *loens, int64_t *offsets, int nfft, void *growing_allocator) { growing_allocator_register_free_c(growing_allocator, free_fft_graph_cache); // if the pointers are changed, we need to update the graph auto &ptrCache = get_ptr_cache(); // kfield -> ptrs auto &graphCache = get_graph_cache(); // kfield -> graphs auto key = cache_key{resol_id, kfield}; auto ptrs = ptrCache.find(key); if (ptrs != ptrCache.end() && (ptrs->second.first != data_real || ptrs->second.second != data_complex)) { // the plan is cached, but the pointers are not correct. we remove and // delete the graph, but we keep the FFT plans, if this happens more often, // we should cache this... std::cout << "WARNING FFT: POINTER CHANGE --> THIS MIGHT BE SLOW" << std::endl; graphCache.erase(key); ptrCache.erase(key); } auto graph = graphCache.find(key); if (graph == graphCache.end()) { // this graph does not exist yet auto plans = plan_all(resol_id, kfield, loens, nfft, offsets); // create a temporary stream hipStream_t stream; HIC_CHECK(hipStreamCreate(&stream)); for (auto &plan : plans) // set the streams plan.set_stream(stream); #if HIPGPU // now create the graph HIC_CHECK(hipStreamBeginCapture(stream, hipStreamCaptureModeGlobal)); for (auto &plan : plans) { plan.exec(data_real, data_complex); } hipGraph_t my_graph; HIC_CHECK(hipStreamEndCapture(stream, &my_graph)); hipGraphExec_t instance; HIC_CHECK(hipGraphInstantiate(&instance, my_graph, NULL, NULL, 0)); #endif #if CUDAGPU // now create the graph hipGraph_t new_graph; hipGraphCreate(&new_graph, 0); for (auto &plan : plans) { HIC_CHECK(hipStreamBeginCapture(stream, hipStreamCaptureModeGlobal)); plan.exec(data_real, data_complex); hipGraph_t my_graph; HIC_CHECK(hipStreamEndCapture(stream, &my_graph)); hipGraphNode_t my_node; HIC_CHECK( hipGraphAddChildGraphNode(&my_node, new_graph, nullptr, 0, my_graph)); } hipGraphExec_t instance; HIC_CHECK(hipGraphInstantiate(&instance, new_graph, NULL, NULL, 0)); HIC_CHECK(hipGraphDestroy(new_graph)); #endif HIC_CHECK(hipStreamDestroy(stream)); graphCache.insert({key, std::shared_ptr( new hipGraphExec_t{instance}, [](auto ptr) { HIC_CHECK(hipGraphExecDestroy(*ptr)); delete ptr; })}); ptrCache.insert({key, std::make_pair(data_real, data_complex)}); } /* running in stream 0 */ HIC_CHECK(hipGraphLaunch(*graphCache.at(key), 0)); HIC_CHECK(hipStreamSynchronize(0)); } template void run_group(typename Type::real *data_real, typename Type::cmplx *data_complex, int resol_id, int kfield, int *loens, int64_t *offsets, int nfft, void *growing_allocator) { auto plans = plan_all(resol_id, kfield, loens, nfft, offsets); for (auto &plan : plans) plan.exec(data_real, data_complex); HIC_CHECK(hipDeviceSynchronize()); } } // namespace extern "C" { #ifdef USE_GRAPHS_FFT #define RUN run_group_graph #else #define RUN run_group #endif void execute_dir_fft_float(float *data_real, hipfftComplex *data_complex, int resol_id, int kfield, int *loens, int64_t *offsets, int nfft, void *growing_allocator) { RUN(data_real, data_complex, resol_id, kfield, loens, offsets, nfft, growing_allocator); } void execute_inv_fft_float(hipfftComplex *data_complex, float *data_real, int resol_id, int kfield, int *loens, int64_t *offsets, int nfft, void *growing_allocator) { RUN(data_real, data_complex, resol_id, kfield, loens, offsets, nfft, growing_allocator); } void execute_dir_fft_double(double *data_real, hipfftDoubleComplex *data_complex, int resol_id, int kfield, int *loens, int64_t *offsets, int nfft, void *growing_allocator) { RUN(data_real, data_complex, resol_id, kfield, loens, offsets, nfft, growing_allocator); } void execute_inv_fft_double(hipfftDoubleComplex *data_complex, double *data_real, int resol_id, int kfield, int *loens, int64_t *offsets, int nfft, void *growing_allocator) { RUN(data_real, data_complex, resol_id, kfield, loens, offsets, nfft, growing_allocator); } #undef RUN void clean_fft(int resol_id) { erase_from_caches(resol_id); erase_from_caches(resol_id); erase_from_caches(resol_id); erase_from_caches(resol_id); } } ectrans-1.8.0/src/trans/gpu/algor/device_mod.F900000664000175000017500000000434415174631767021564 0ustar alastairalastair! (C) Copyright 2020- ECMWF. ! ! 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. ! MODULE DEVICE_MOD #ifdef CUDAGPU #define hipDeviceSynchronize cudaDeviceSynchronize #define hipStreamSynchronize cudaStreamSynchronize #define hipStreamDestroy cudaStreamDestroy #define hipSetDevice cudaSetDevice #define hipGetDevice cudaGetDevice #define hipGetDeviceCount cudaGetDeviceCount #endif INTERFACE DEVICE_SYNC INTEGER FUNCTION DEVICE_SYNCHRONIZE() BIND(C, NAME='hipDeviceSynchronize') END FUNCTION DEVICE_SYNCHRONIZE END INTERFACE DEVICE_SYNC INTERFACE DEVICESTREAMSYNC INTEGER FUNCTION DEVICE_STREAM_SYNCHRONIZE(STREAM) BIND(C, NAME='hipStreamSynchronize') USE ISO_C_BINDING, ONLY: C_PTR TYPE(C_PTR) :: STREAM END FUNCTION DEVICE_STREAM_SYNCHRONIZE END INTERFACE DEVICESTREAMSYNC INTERFACE DEVICESTREAMDESTROY INTEGER FUNCTION DEVICE_STREAM_DESTROY(STREAM) BIND(C, NAME='hipStreamDestroy') USE ISO_C_BINDING, ONLY: C_PTR TYPE(C_PTR) :: STREAM END FUNCTION DEVICE_STREAM_DESTROY END INTERFACE DEVICESTREAMDESTROY INTERFACE DEVICESETDEVICE INTEGER FUNCTION DEVICE_SETDEVICE(DEVNUM) BIND(C, NAME='hipSetDevice') USE ISO_C_BINDING, ONLY: C_INT INTEGER(C_INT), VALUE :: DEVNUM END FUNCTION DEVICE_SETDEVICE END INTERFACE DEVICESETDEVICE INTERFACE DEVICEGETDEVICE INTEGER FUNCTION DEVICE_GETDEVICE(DEVNUM) BIND(C, NAME='hipGetDevice') USE ISO_C_BINDING, ONLY: C_INT INTEGER(C_INT) :: DEVNUM END FUNCTION DEVICE_GETDEVICE END INTERFACE DEVICEGETDEVICE INTERFACE DEVICEGETDEVICECOUNT INTEGER FUNCTION DEVICE_GETDEVICECOUNT(DEVNUM) BIND(C, NAME='hipGetDeviceCount') USE ISO_C_BINDING, ONLY: C_INT INTEGER(C_INT) :: DEVNUM END FUNCTION DEVICE_GETDEVICECOUNT END INTERFACE DEVICEGETDEVICECOUNT INTERFACE DEVICEGETMEMINFO INTEGER FUNCTION DEVICE_MEMGETINFO(MEMFREE_MB, MEMTOTAL_MB) BIND(C, NAME='c_hipmemgetinfo') USE ISO_C_BINDING, ONLY: C_INT INTEGER(C_INT) :: MEMFREE_MB, MEMTOTAL_MB END FUNCTION DEVICE_MEMGETINFO END INTERFACE DEVICEGETMEMINFO END MODULE DEVICE_MOD ectrans-1.8.0/src/trans/gpu/algor/hicfft.cuda.cu0000777000175000017500000000000015174631767024431 2hicfft.hip.cppustar alastairalastairectrans-1.8.0/src/trans/gpu/algor/hicfft_cuda.h0000664000175000017500000001207215174631767021613 0ustar alastairalastair// (C) Copyright 2000- ECMWF. // // 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. // Include cufft header and provide CPP macros to rewrite HIP and hipfft names // to CUDA and cufft names #ifndef __HICFFT_CUDA_H__ #define __HICFFT_CUDA_H__ #include "cufft.h" // Library Names #define hipfft cufft #define HIPFFT CUFFT // CPP macros #define HIPFFT_SUCCESS CUFFT_SUCCESS #define HIPFFT_R2C CUFFT_R2C #define HIPFFT_C2R CUFFT_C2R #define HIPFFT_D2Z CUFFT_D2Z #define HIPFFT_Z2D CUFFT_Z2D // Constants and types #define hipError_t cudaError_t #define hipSuccess cudaSuccess #define hipfftHandle cufftHandle #define hipfftType cufftType #define hipfftResult cufftResult #define hipfftComplex cufftComplex #define hipfftReal cufftReal #define hipfftDoubleComplex cufftDoubleComplex #define hipfftDoubleReal cufftDoubleReal #define hipGraph_t cudaGraph_t #define hipGraphNode_t cudaGraphNode_t #define hipGraphExec_t cudaGraphExec_t #define hipStream_t cudaStream_t #define hipfftCreate cufftCreate #define hipfftDestroy cufftDestroy #define hipfftPlanMany cufftPlanMany #define hipfftGetSize cufftGetSize #define hipfftSetAutoAllocation cufftSetAutoAllocation #define hipfftSetStream cufftSetStream #define hipStreamCreate cudaStreamCreate #define hipStreamDestroy cudaStreamDestroy #define hipSetStream cudaSetStream #define hipGraphCreate cudaGraphCreate #define hipGraphDestroy cudaGraphDestroy #define hipGraphLaunch cudaGraphLaunch #define hipGraphExecDestroy cudaGraphExecDestroy #define hipStreamCaptureModeGlobal cudaStreamCaptureModeGlobal #define hipStreamBeginCapture cudaStreamBeginCapture #define hipStreamEndCapture cudaStreamEndCapture #define hipGraphAddChildGraphNode cudaGraphAddChildGraphNode #define hipGraphInstantiate cudaGraphInstantiate #define hipfftExecR2C cufftExecR2C #define hipfftExecC2R cufftExecC2R #define hipfftExecD2Z cufftExecD2Z #define hipfftExecZ2D cufftExecZ2D // Runtime calls #define hipDeviceSynchronize cudaDeviceSynchronize #define hipStreamSynchronize cudaStreamSynchronize #define hipDeviceReset cudaDeviceReset #define _hipGetErrorEnum _cudaGetErrorEnum #define hipFree cudaFree #define hipMalloc cudaMalloc inline static const char * _fftGetErrorEnum(cufftResult error) { switch (error) { case CUFFT_SUCCESS: return "CUFFT_SUCCESS"; case CUFFT_INVALID_PLAN: return "CUFFT_INVALID_PLAN"; case CUFFT_ALLOC_FAILED: return "CUFFT_ALLOC_FAILED"; case CUFFT_INVALID_TYPE: return "CUFFT_INVALID_TYPE"; case CUFFT_INVALID_VALUE: return "CUFFT_INVALID_VALUE"; case CUFFT_INTERNAL_ERROR: return "CUFFT_INTERNAL_ERROR"; case CUFFT_EXEC_FAILED: return "CUFFT_EXEC_FAILED"; case CUFFT_SETUP_FAILED: return "CUFFT_SETUP_FAILED"; case CUFFT_INVALID_SIZE: return "CUFFT_INVALID_SIZE"; case CUFFT_UNALIGNED_DATA: return "CUFFT_UNALIGNED_DATA"; case CUFFT_INVALID_DEVICE: return "CUFFT_INVALID_DEVICE"; case CUFFT_NO_WORKSPACE: return "CUFFT_NO_WORKSPACE"; case CUFFT_NOT_IMPLEMENTED: return "CUFFT_NOT_IMPLEMENTED"; case CUFFT_NOT_SUPPORTED: return "CUFFT_NOT_SUPPORTED"; // These are only available from 13.0 onwards // https://docs.nvidia.com/cuda/archive/12.9.1/cufft/index.html#return-value-cufftresult #if defined(CUDART_VERSION) && CUDART_VERSION >= 13000 case CUFFT_MISSING_DEPENDENCY: return "CUFFT_MISSING_DEPENDENCY"; case CUFFT_NVRTC_FAILURE: return "CUFFT_NVRTC_FAILURE"; case CUFFT_NVJITLINK_FAILURE: return "CUFFT_NVJITLINK_FAILURE"; case CUFFT_NVSHMEM_FAILURE: return "CUFFT_NVSHMEM_FAILURE"; #endif // These are deprecated from CUDA 13.0 onwards // https://docs.nvidia.com/cuda/cufft/#deprecated-functionality #if defined(CUDART_VERSION) && CUDART_VERSION < 13000 case CUFFT_INCOMPLETE_PARAMETER_LIST: return "CUFFT_INCOMPLETE_PARAMETER_LIST"; case CUFFT_PARSE_ERROR: return "CUFFT_PARSE_ERROR"; case CUFFT_LICENSE_ERROR: return "CUFFT_LICENSE_ERROR"; #endif } return ""; } #define HIC_CHECK(e) \ { \ cudaError_t err = (e); \ if (err != cudaSuccess) { \ fprintf(stderr, "CUDA error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ #e, cudaGetErrorString(err)); \ exit(EXIT_FAILURE); \ } \ } #endif ectrans-1.8.0/src/trans/gpu/algor/hicblas_gemm.hip.cpp0000664000175000017500000003567415174631767023115 0ustar alastairalastair// (C) Copyright 2000- ECMWF. // (C) Copyright 2024- NVIDIA. // // 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. #include #include #include #include #include #include #include "hicblas.h" #ifdef USE_CUTLASS #include "cutlass/gemm/device/gemm.h" #endif #include "growing_allocator.h" bool hip_alreadyAllocated_sgemm = false; bool hip_alreadyAllocated_sgemm_handle = false; hipblasHandle_t handle_hip_sgemm; namespace { struct cache_key { int resol_id; int m; int blas_id; bool operator==(const cache_key &other) const { return resol_id == other.resol_id && m == other.m && blas_id == other.blas_id; } cache_key(int resol_id_, int m_, int blas_id_) : resol_id(resol_id_), m(m_), blas_id(blas_id_) {} }; } // namespace template <> struct std::hash { std::size_t operator()(const cache_key &k) const { return k.blas_id * 1000000 + k.resol_id * 10000 + k.m; } }; namespace { template auto &get_graph_cache() { // we store at most one graph per "m" (# fields) and "blas id" and resolution static std::unordered_map> graphCache; return graphCache; } template auto &get_ptr_cache() { using real_t = typename Gemm::real_type; static std::unordered_map< cache_key, std::tuple> ptrCache; return ptrCache; } template void free_gemm_graph_cache(float *, size_t) { get_graph_cache().clear(); get_ptr_cache().clear(); } template void erase_resol_from_cache(Cache &cache, int resol_id) { // Note that in C++20 this could also be std::erase_if int erased = 0; for (auto it = cache.begin(); it != cache.end();) { if (it->first.resol_id == resol_id) { it = cache.erase(it); ++erased; } else ++it; } } template void erase_from_caches(int resol_id) { erase_resol_from_cache(get_graph_cache(), resol_id); erase_resol_from_cache(get_ptr_cache(), resol_id); } // this version is using graphs and caches the graphs template void run_group_graph(Gemm &&gemm, int resol_id, int m, const int *n, const int *k, Real alpha, const Real *A, int lda, const int64_t *offsetsA, const Real *B, const int *ldb, const int64_t *offsetsB, Real beta, Real *C, int ldc, const int64_t *offsetsC, int batchCount, hipStream_t stream, int blas_id, void *growing_allocator) { growing_allocator_register_free_c(growing_allocator, free_gemm_graph_cache); // we store at most one graph per "m" (# fields) and "blas id" auto &graphCache = get_graph_cache(); // we also store A, B, and C and recreate the graph if they change auto &ptrCache = get_ptr_cache(); auto key = cache_key{resol_id, m, blas_id}; auto ptrs = ptrCache.find(key); if (ptrs != ptrCache.end() && (std::get<0>(ptrs->second) != A || std::get<1>(ptrs->second) != B || std::get<2>(ptrs->second) != C)) { // the plan is cached, but the pointers are not correct. we remove and // delete the graph, but we keep the hipblas handles, if this happens more // often, we should cache this... std::cout << "WARNING GEMM: POINTER CHANGE - Graph recreation might be slow." << std::endl; std::cout << "We have an entry with key {m=" << m << ", blas_id=" << blas_id << ", resol_id=" << resol_id << "}\n"; std::cout << "Pointers: " << std::get<0>(ptrs->second) << ", " << std::get<1>(ptrs->second) << ", " << std::get<2>(ptrs->second) << " vs. " << A << ", " << B << ", " << C << std::endl; graphCache.erase(key); ptrCache.erase(key); } auto graph = graphCache.find(key); if (graph == graphCache.end()) { // this graph does not exist yet hipStream_t captureStream; HIC_CHECK(hipStreamCreate(&captureStream)); #ifdef USE_CUTLASS hipGraph_t new_graph; hipGraphCreate(&new_graph, 0); for (int i = 0; i < batchCount; ++i) { if (m == 0 || n[i] == 0 || k[i] == 0) continue; HIC_CHECK(hipStreamBeginCapture(captureStream, hipStreamCaptureModeGlobal)); gemm(captureStream, m, n[i], k[i], alpha, A + offsetsA[i], lda, B + offsetsB[i], ldb[i], beta, C + offsetsC[i], ldc); hipGraph_t my_graph; HIC_CHECK(hipStreamEndCapture(captureStream, &my_graph)); hipGraphNode_t my_node; HIC_CHECK( hipGraphAddChildGraphNode(&my_node, new_graph, nullptr, 0, my_graph)); } hipGraphExec_t instance; HIC_CHECK(hipGraphInstantiate(&instance, new_graph, NULL, NULL, 0)); HIC_CHECK(hipGraphDestroy(new_graph)); #else HIC_CHECK(hipStreamBeginCapture(captureStream, hipStreamCaptureModeGlobal)); for (int i = 0; i < batchCount; ++i) { if (m == 0 || n[i] == 0 || k[i] == 0) continue; gemm(captureStream, m, n[i], k[i], alpha, A + offsetsA[i], lda, B + offsetsB[i], ldb[i], beta, C + offsetsC[i], ldc); } hipGraph_t my_graph; HIC_CHECK(hipStreamEndCapture(captureStream, &my_graph)); hipGraphExec_t instance; HIC_CHECK(hipGraphInstantiate(&instance, my_graph, NULL, NULL, 0)); #endif HIC_CHECK(hipStreamDestroy(captureStream)); graphCache.insert({key, std::shared_ptr( new hipGraphExec_t{instance}, [](auto ptr) { HIC_CHECK(hipGraphExecDestroy(*ptr)); delete ptr; })}); ptrCache.insert({key, std::make_tuple(A, B, C)}); } HIC_CHECK(hipGraphLaunch(*graphCache.at(key), stream)); HIC_CHECK(hipStreamSynchronize(stream)); } // stupid simple gemm calls template void run_group(Gemm &&gemm, int resol_id, int m, const int *n, const int *k, Real alpha, const Real *A, int lda, const int64_t *offsetsA, const Real *B, const int *ldb, const int64_t *offsetsB, Real beta, Real *C, int ldc, const int64_t *offsetsC, int batchCount, hipStream_t stream, int = -1) { for (int i = 0; i < batchCount; ++i) { if (m == 0 || n[i] == 0 || k[i] == 0) continue; gemm(stream, m, n[i], k[i], alpha, A + offsetsA[i], lda, B + offsetsB[i], ldb[i], beta, C + offsetsC[i], ldc); } HIC_CHECK(hipStreamSynchronize(stream)); } #ifdef USE_CUTLASS #include "hicblas_cutlass.cuda.h" #endif hipblasHandle_t get_hipblas_handle() { static hipblasHandle_t handle; if (!handle) HICBLAS_CHECK(hipblasCreate(&handle)); return handle; } template struct hipblas_gemm_grouped { public: using real_type = Real; hipblas_gemm_grouped(hipblasOperation_t transa, hipblasOperation_t transb) : transa_(transa), transb_(transb) { // we need to get the hipblas handle here, otherwise this could be created // during graph capturing get_hipblas_handle(); }; void operator()(hipStream_t stream, int m, int n, int k, Real alpha, const Real *A, int lda, const Real *B, int ldb, Real beta, Real *C, int ldc) const { hipblasHandle_t handle = get_hipblas_handle(); HICBLAS_CHECK(hipblasSetStream(handle, stream)); if constexpr (std::is_same::value) HICBLAS_CHECK(hipblasSgemm(handle, transa_, transb_, m, n, k, &alpha, A, lda, B, ldb, &beta, C, ldc)); if constexpr (std::is_same::value) HICBLAS_CHECK(hipblasDgemm(handle, transa_, transb_, m, n, k, &alpha, A, lda, B, ldb, &beta, C, ldc)); } private: hipblasOperation_t transa_, transb_; }; #ifndef USE_CUTLASS void hipblas_sgemm_wrapper_grouped( int resol_id, int blas_id, char transa, char transb, int m, const int *n, const int *k, float alpha, const float *A, int lda, const int64_t *offsetsA, const float *B, const int *ldb, const int64_t *offsetsB, float beta, float *C, int ldc, const int64_t *offsetsC, int batchCount, hipStream_t stream, void *growing_allocator) { hipblasOperation_t op_t1 = HIPBLAS_OP_N, op_t2 = HIPBLAS_OP_N; if (transa == 'T' || transa == 't') op_t1 = HIPBLAS_OP_T; if (transb == 'T' || transb == 't') op_t2 = HIPBLAS_OP_T; #ifdef USE_GRAPHS_GEMM run_group_graph(hipblas_gemm_grouped(op_t1, op_t2), resol_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, blas_id, growing_allocator); #else run_group(hipblas_gemm_grouped(op_t1, op_t2), resol_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream); #endif } #endif void hipblas_dgemm_wrapper_grouped(int resol_id, int blas_id, char transa, char transb, int m, const int *n, const int *k, double alpha, const double *A, int lda, const int64_t *offsetsA, const double *B, const int *ldb, const int64_t *offsetsB, double beta, double *C, int ldc, const int64_t *offsetsC, int batchCount, hipStream_t stream, void *) { hipblasOperation_t op_t1 = HIPBLAS_OP_N, op_t2 = HIPBLAS_OP_N; if (transa == 'T' || transa == 't') op_t1 = HIPBLAS_OP_T; if (transb == 'T' || transb == 't') op_t2 = HIPBLAS_OP_T; run_group(hipblas_gemm_grouped(op_t1, op_t2), resol_id, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, stream, blas_id); } } // namespace extern "C" { void hipblas_dgemm_wrapper(char transa, char transb, int m, int n, int k, double alpha, const double *A, int lda, int tda, const double *B, int ldb, int tdb, double beta, double *C, int ldc, int tdc, int batchCount, size_t stream, void *growing_allocator) { hipblasOperation_t op_t1 = HIPBLAS_OP_N, op_t2 = HIPBLAS_OP_N; if (transa == 'T' || transa == 't') op_t1 = HIPBLAS_OP_T; if (transb == 'T' || transb == 't') op_t2 = HIPBLAS_OP_T; hipblasHandle_t handle = get_hipblas_handle(); HICBLAS_CHECK(hipblasSetStream(handle, *(hipStream_t *)stream)); HICBLAS_CHECK(hipblasDgemmStridedBatched( handle, op_t1, op_t2, m, n, k, &alpha, (const double *)A, lda, tda, (const double *)B, ldb, tdb, &beta, (double *)C, ldc, tdc, batchCount)); } void hipblas_sgemm_wrapper(char transa, char transb, int m, int n, int k, float alpha, const float *A, int lda, int tda, const float *B, int ldb, int tdb, float beta, float *C, int ldc, int tdc, int batchCount, void *growing_allocator) { hipblasOperation_t op_t1 = HIPBLAS_OP_N, op_t2 = HIPBLAS_OP_N; if (transa == 'T' || transa == 't') op_t1 = HIPBLAS_OP_T; if (transb == 'T' || transb == 't') op_t2 = HIPBLAS_OP_T; if (!hip_alreadyAllocated_sgemm_handle) { HICBLAS_CHECK(hipblasCreate(&handle_hip_sgemm)); hip_alreadyAllocated_sgemm_handle = true; } HICBLAS_CHECK(hipblasSgemmStridedBatched( handle_hip_sgemm, op_t1, op_t2, m, n, k, &alpha, (const float *)A, lda, tda, (const float *)B, ldb, tdb, &beta, (float *)C, ldc, tdc, batchCount)); } void hipblas_sgemm_wrapper_grouped( int resol_id, int blas_id, char transa, char transb, int m, const int *n, const int *k, float alpha, const float *A, int lda, const int64_t *offsetsA, const float *B, const int *ldb, const int64_t *offsetsB, float beta, float *C, int ldc, const int64_t *offsetsC, int batchCount, size_t stream, void *growing_allocator) { #ifdef USE_CUTLASS cutlass_sgemm_wrapper_grouped(resol_id, blas_id, transa, transb, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, *(hipStream_t *)stream, growing_allocator); #else hipblas_sgemm_wrapper_grouped(resol_id, blas_id, transa, transb, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, *(hipStream_t *)stream, growing_allocator); #endif } void hipblas_dgemm_wrapper_grouped(int resol_id, int blas_id, char transa, char transb, int m, const int *n, const int *k, double alpha, const double *A, int lda, const int64_t *offsetsA, const double *B, const int *ldb, const int64_t *offsetsB, double beta, double *C, int ldc, const int64_t *offsetsC, int batchCount, size_t stream, void *growing_allocator) { hipblas_dgemm_wrapper_grouped(resol_id, blas_id, transa, transb, m, n, k, alpha, A, lda, offsetsA, B, ldb, offsetsB, beta, C, ldc, offsetsC, batchCount, *(hipStream_t *)stream, growing_allocator); } void clean_gemm(int resol_id) { erase_from_caches>(resol_id); erase_from_caches>(resol_id); #ifdef USE_CUTLASS erase_from_caches>(resol_id); erase_from_caches>(resol_id); erase_from_caches>(resol_id); erase_from_caches>(resol_id); erase_from_caches>(resol_id); erase_from_caches>(resol_id); erase_from_caches>(resol_id); erase_from_caches>(resol_id); #endif } } ectrans-1.8.0/src/trans/gpu/algor/hicblas_hip.h0000664000175000017500000000631615174631767021625 0ustar alastairalastair// (C) Copyright 2000- ECMWF. // // 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. // Include hip runtime and hipblas headers #ifndef __HICBLAS_HIP_H__ #define __HICBLAS_HIP_H__ #include #include #ifdef __clang__ #pragma clang diagnostic push #pragma clang diagnostic ignored "-W#pragma-messages" #endif #include "hipblas/hipblas.h" #ifdef __clang__ #pragma clang diagnostic pop #endif inline static const char * _blasGetErrorEnum(hipblasStatus_t error) { switch (error) { case HIPBLAS_STATUS_SUCCESS: return "HIPBLAS_STATUS_SUCCESS"; case HIPBLAS_STATUS_NOT_INITIALIZED: return "HIPBLAS_STATUS_NOT_INITIALIZED"; case HIPBLAS_STATUS_ALLOC_FAILED: return "HIPBLAS_STATUS_ALLOC_FAILED"; case HIPBLAS_STATUS_INVALID_VALUE: return "HIPBLAS_STATUS_INVALID_VALUE"; case HIPBLAS_STATUS_ARCH_MISMATCH: return "HIPBLAS_STATUS_ARCH_MISMATCH"; case HIPBLAS_STATUS_MAPPING_ERROR: return "HIPBLAS_STATUS_MAPPING_ERROR"; case HIPBLAS_STATUS_EXECUTION_FAILED: return "HIPBLAS_STATUS_EXECUTION_FAILED"; case HIPBLAS_STATUS_INTERNAL_ERROR: return "HIPBLAS_STATUS_INTERNAL_ERROR"; case HIPBLAS_STATUS_NOT_SUPPORTED: return "HIPBLAS_STATUS_NOT_SUPPORTED"; case HIPBLAS_STATUS_HANDLE_IS_NULLPTR: return "HIPBLAS_STATUS_HANDLE_IS_NULLPTR"; case HIPBLAS_STATUS_INVALID_ENUM: return "HIPBLAS_STATUS_INVALID_ENUM"; case HIPBLAS_STATUS_UNKNOWN: return "HIPBLAS_STATUS_UNKNOWN"; } return ""; } #define HICBLAS_CHECK(e) \ { \ hipblasStatus_t err = (e); \ if (err != HIPBLAS_STATUS_SUCCESS) { \ fprintf(stderr, "HIP error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ #e, _blasGetErrorEnum(err)); \ exit(EXIT_FAILURE); \ } \ } #define HIC_CHECK(e) \ { \ hipError_t err = (e); \ if (err != hipSuccess) { \ fprintf(stderr, "HIP error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ #e, hipGetErrorString(err)); \ exit(EXIT_FAILURE); \ } \ } #endif ectrans-1.8.0/src/trans/gpu/algor/buffered_allocator_mod.F900000664000175000017500000002110315174631767024137 0ustar alastairalastair! (C) Copyright 2022- NVIDIA. ! ! 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. #define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) MODULE BUFFERED_ALLOCATOR_MOD USE EC_PARKIND, ONLY: JPIM, JPIB USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE ISO_C_BINDING, ONLY: C_INT8_T, C_SIZE_T, C_LOC, C_F_POINTER USE GROWING_ALLOCATOR_MOD, ONLY: GROWING_ALLOCATION_TYPE #ifdef ACCGPU USE OPENACC, ONLY: ACC_ASYNC_SYNC #endif IMPLICIT NONE PRIVATE PUBLIC :: BUFFERED_ALLOCATOR, ALLOCATION_RESERVATION_HANDLE, RESERVE, ASSIGN_PTR, GET_ALLOCATION PUBLIC :: MAKE_BUFFERED_ALLOCATOR, INSTANTIATE_ALLOCATOR ! The buffered allocator uses double buffering. The idea is that the allocator ! iterates through its two buffers, and each allocate returns one or the other ! buffer. It is a two-step allocator - it expects you to create reservation ! handles first for all allocations. Then the allocator is instantiated (i.e. ! the buffers are actually allocated). Instantiation will do an allocation ! that is large enough two hold all consecutive allocations. Other allocations ! might be overwritten (like you can't access the allocation done two steps ! before). ! After instantiation, you can retrieve your buffers by passing the allocator ! and the handles to GET_ALLOCATION. Also, we provide helper function ! ASSIGN_PTR, because an allocation is often split among several "sub-buffers", ! so you can for example assign the first half of an allocation to one ! buffer, while the second half to another buffer. ! If you see "Logical errors" that usually means you try to retrieve a buffer ! that is not within the reserved allocation size. This might be a valid ! region in the sense that it is physically allocated, but it might be part of ! the double buffer. INTEGER(KIND=JPIM), PARAMETER :: NBUF = 2 TYPE BUFFERED_ALLOCATOR INTEGER(KIND=C_SIZE_T) :: BUFR_SZ(0:NBUF-1) INTEGER(KIND=JPIM) :: NEXT_BUF TYPE(GROWING_ALLOCATION_TYPE), POINTER :: PTR END TYPE TYPE ALLOCATION_RESERVATION_HANDLE INTEGER(KIND=C_SIZE_T) :: SZ INTEGER(KIND=JPIM) :: BUF END TYPE INTERFACE ASSIGN_PTR MODULE PROCEDURE ASSIGN_PTR_FLOAT, ASSIGN_PTR_DOUBLE END INTERFACE CONTAINS ! TODO This is not perfect yet. We will over-allocate up to 2X in theory. ! It would be better to always keep the previous allocation size and then ! have one allocation sitting at the the top, and the double-buffer at ! the bottom of the allocation. FUNCTION MAKE_BUFFERED_ALLOCATOR() IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR) :: MAKE_BUFFERED_ALLOCATOR MAKE_BUFFERED_ALLOCATOR%BUFR_SZ(:) = 0 MAKE_BUFFERED_ALLOCATOR%NEXT_BUF = 0 END FUNCTION MAKE_BUFFERED_ALLOCATOR FUNCTION RESERVE(ALLOCATOR, SZ, WHO) IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR INTEGER(KIND=C_SIZE_T), INTENT(IN) :: SZ CHARACTER(*), INTENT(IN), OPTIONAL :: WHO TYPE(ALLOCATION_RESERVATION_HANDLE) :: RESERVE ALLOCATOR%BUFR_SZ(ALLOCATOR%NEXT_BUF) = MAX(ALLOCATOR%BUFR_SZ(ALLOCATOR%NEXT_BUF),SZ) RESERVE%BUF = ALLOCATOR%NEXT_BUF RESERVE%SZ = SZ ALLOCATOR%NEXT_BUF = MOD(ALLOCATOR%NEXT_BUF+1,NBUF) END FUNCTION RESERVE SUBROUTINE INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) USE GROWING_ALLOCATOR_MOD, ONLY: REALLOCATE_GROWING_ALLOCATION IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(INOUT) :: ALLOCATOR !!TYPE(GROWING_ALLOCATION_TYPE), INTENT(IN), POINTER :: GROWING_ALLOCATION TYPE(GROWING_ALLOCATION_TYPE), TARGET, INTENT(INOUT) :: GROWING_ALLOCATION INTEGER :: I DO I = 0, NBUF-1 ALLOCATOR%BUFR_SZ(I) = ALIGN(ALLOCATOR%BUFR_SZ(I),128) ENDDO ALLOCATOR%PTR => GROWING_ALLOCATION CALL REALLOCATE_GROWING_ALLOCATION(GROWING_ALLOCATION, SUM(ALLOCATOR%BUFR_SZ)) END SUBROUTINE FUNCTION GET_ALLOCATION(ALLOCATOR, RESERVATION) IMPLICIT NONE TYPE(BUFFERED_ALLOCATOR), INTENT(IN) :: ALLOCATOR TYPE(ALLOCATION_RESERVATION_HANDLE), INTENT(IN) :: RESERVATION INTEGER(KIND=C_INT8_T), POINTER :: GET_ALLOCATION(:) IF (RESERVATION%SZ > ALLOCATOR%BUFR_SZ(RESERVATION%BUF)) THEN CALL ABORT_TRANS( "Logical Error in GET_ALLOCATION") ENDIF IF (RESERVATION%BUF == 0) THEN GET_ALLOCATION(1:) => ALLOCATOR%PTR%PTR(1:RESERVATION%SZ) ELSE GET_ALLOCATION(1:) => ALLOCATOR%PTR%PTR(SUM(ALLOCATOR%BUFR_SZ(0:RESERVATION%BUF-1))+1: & SUM(ALLOCATOR%BUFR_SZ(0:RESERVATION%BUF-1))+RESERVATION%SZ) ENDIF END FUNCTION GET_ALLOCATION SUBROUTINE ASSIGN_PTR_FLOAT(DST, SRC, START_IN_BYTES, LENGTH_IN_BYTES, SET_VALUE, SET_STREAM) USE ISO_C_BINDING, ONLY: C_FLOAT, C_F_POINTER, C_SIZEOF USE ISO_FORTRAN_ENV, ONLY: INT32 IMPLICIT NONE INTEGER(KIND=C_INT8_T), POINTER, INTENT(IN) :: SRC(:) REAL(KIND=C_FLOAT), POINTER, INTENT(OUT) :: DST(:) LOGICAL, INTENT(IN), OPTIONAL :: SET_VALUE INTEGER(KIND=INT32), INTENT(IN), OPTIONAL :: SET_STREAM LOGICAL :: SET_VALUE_EFF INTEGER(KIND=INT32) :: SET_STREAM_EFF INTEGER(KIND=C_SIZE_T) :: START_IN_BYTES, LENGTH_IN_BYTES, END_IN_BYTES, J IF (START_IN_BYTES + LENGTH_IN_BYTES - 1 > SIZE(SRC, KIND=C_SIZE_T)) THEN CALL ABORT_TRANS("Logical Error in ASSIGN_PTR - OOB assignment") ENDIF IF (START_IN_BYTES < 1) THEN CALL ABORT_TRANS("Logical Error in ASSIGN_PTR - OOB assignment") ENDIF IF (PRESENT(SET_VALUE)) THEN SET_VALUE_EFF = SET_VALUE ELSE SET_VALUE_EFF = .FALSE. ENDIF IF (PRESENT(SET_STREAM)) THEN SET_STREAM_EFF = SET_STREAM ELSE #ifdef ACCGPU SET_STREAM_EFF = ACC_ASYNC_SYNC #endif ENDIF IF (SET_VALUE_EFF .AND. LENGTH_IN_BYTES > 0) THEN ! This option is turned off by default, but for experimentation we can turn it on. This is ! setting all bits to 1 (meaning NaN in floating point) END_IN_BYTES=START_IN_BYTES+LENGTH_IN_BYTES-1 #ifdef ACCGPU !$ACC PARALLEL PRESENT(SRC) ASYNC(SET_STREAM_EFF) #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) FIRSTPRIVATE(START_IN_BYTES,END_IN_BYTES,SRC) #endif DO J=START_IN_BYTES,END_IN_BYTES SRC(J) = -1 ENDDO #ifdef ACCGPU !$ACC END PARALLEL #endif ENDIF CALL C_F_POINTER(C_LOC(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1)), DST, & & [C_SIZEOF(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1))/C_SIZEOF(DST(0))]) END SUBROUTINE ASSIGN_PTR_FLOAT SUBROUTINE ASSIGN_PTR_DOUBLE(DST, SRC, START_IN_BYTES, LENGTH_IN_BYTES, SET_VALUE, SET_STREAM) USE ISO_C_BINDING, ONLY: C_DOUBLE, C_F_POINTER, C_SIZEOF USE ISO_FORTRAN_ENV, ONLY: INT32 IMPLICIT NONE INTEGER(KIND=C_INT8_T), POINTER, INTENT(IN) :: SRC(:) REAL(KIND=C_DOUBLE), POINTER, INTENT(OUT) :: DST(:) LOGICAL, INTENT(IN), OPTIONAL :: SET_VALUE INTEGER(KIND=INT32), INTENT(IN), OPTIONAL :: SET_STREAM LOGICAL :: SET_VALUE_EFF INTEGER(KIND=INT32) :: SET_STREAM_EFF INTEGER(KIND=C_SIZE_T) :: START_IN_BYTES, LENGTH_IN_BYTES, END_IN_BYTES, J IF (START_IN_BYTES + LENGTH_IN_BYTES - 1 > SIZE(SRC, KIND=C_SIZE_T)) THEN CALL ABORT_TRANS("Logical Error in ASSIGN_PTR - OOB assignment") ENDIF IF (START_IN_BYTES < 1) THEN CALL ABORT_TRANS("Logical Error in ASSIGN_PTR - OOB assignment") ENDIF IF (PRESENT(SET_VALUE)) THEN SET_VALUE_EFF = SET_VALUE ELSE SET_VALUE_EFF = .FALSE. ENDIF IF (PRESENT(SET_STREAM)) THEN SET_STREAM_EFF = SET_STREAM ELSE #ifdef ACCGPU SET_STREAM_EFF = ACC_ASYNC_SYNC #endif ENDIF IF (SET_VALUE_EFF .AND. LENGTH_IN_BYTES > 0) THEN ! This option is turned off by default, but for experimentation we can turn it on. This is ! setting all bits to 1 (meaning NaN in floating point) END_IN_BYTES=START_IN_BYTES+LENGTH_IN_BYTES-1 #ifdef ACCGPU !$ACC PARALLEL PRESENT(SRC) ASYNC(SET_STREAM_EFF) #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO DEFAULT(NONE) FIRSTPRIVATE(START_IN_BYTES,END_IN_BYTES,SRC) #endif DO J=START_IN_BYTES,END_IN_BYTES SRC(J) = -1 ENDDO #ifdef ACCGPU !$ACC END PARALLEL #endif ENDIF CALL C_F_POINTER(C_LOC(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1)), DST, & & [C_SIZEOF(SRC(START_IN_BYTES:START_IN_BYTES+LENGTH_IN_BYTES-1))/C_SIZEOF(DST(0))]) END SUBROUTINE ASSIGN_PTR_DOUBLE END MODULE ectrans-1.8.0/src/trans/gpu/algor/hicfft_hip.h0000664000175000017500000000523415174631767021461 0ustar alastairalastair// (C) Copyright 2000- ECMWF. // // 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. // Include hip runtime and hipfft headers and provide error enum translation #ifndef __HICFFT_HIP_H__ #define __HICFFT_HIP_H__ #ifdef __clang__ #pragma clang diagnostic push #pragma clang diagnostic ignored "-W#pragma-messages" #endif #include #include "hipfft/hipfft.h" #ifdef __clang__ #pragma clang diagnostic pop #endif inline static const char * _fftGetErrorEnum(hipfftResult error) { switch (error) { case HIPFFT_SUCCESS: return "HIPFFT_SUCCESS"; case HIPFFT_INVALID_PLAN: return "HIPFFT_INVALID_PLAN"; case HIPFFT_ALLOC_FAILED: return "HIPFFT_ALLOC_FAILED"; case HIPFFT_INVALID_TYPE: return "HIPFFT_INVALID_TYPE"; case HIPFFT_INVALID_VALUE: return "HIPFFT_INVALID_VALUE"; case HIPFFT_INTERNAL_ERROR: return "HIPFFT_INTERNAL_ERROR"; case HIPFFT_EXEC_FAILED: return "HIPFFT_EXEC_FAILED"; case HIPFFT_SETUP_FAILED: return "HIPFFT_SETUP_FAILED"; case HIPFFT_INVALID_SIZE: return "HIPFFT_INVALID_SIZE"; case HIPFFT_UNALIGNED_DATA: return "HIPFFT_UNALIGNED_DATA"; case HIPFFT_INCOMPLETE_PARAMETER_LIST: return "HIPFFT_INCOMPLETE_PARAMETER_LIST"; case HIPFFT_INVALID_DEVICE: return "HIPFFT_INVALID_DEVICE"; case HIPFFT_PARSE_ERROR: return "HIPFFT_PARSE_ERROR"; case HIPFFT_NO_WORKSPACE: return "HIPFFT_NO_WORKSPACE"; case HIPFFT_NOT_IMPLEMENTED: return "HIPFFT_NOT_IMPLEMENTED"; case HIPFFT_NOT_SUPPORTED: return "HIPFFT_NOT_SUPPORTED"; } return ""; } #define HIC_CHECK(e) \ { \ hipError_t err = (e); \ if (err != hipSuccess) { \ fprintf(stderr, "HIP error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ #e, hipGetErrorString(err)); \ exit(EXIT_FAILURE); \ } \ } #endif ectrans-1.8.0/src/trans/gpu/algor/hicblas_cuda.h0000664000175000017500000001110615174631767021752 0ustar alastairalastair// (C) Copyright 2000- ECMWF. // // 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. // Include cublas header and provide CPP macros to rewrite HIP and hipblas names // to CUDA and cublas names #ifndef __HICBLAS_CUDA_H__ #define __HICBLAS_CUDA_H__ #include "cublas_v2.h" #include #include // Library name #define hipblas cublas #define HIPBLAS CUBLAS // CPP definitions #define HIPBLAS_OP_T CUBLAS_OP_T #define HIPBLAS_OP_N CUBLAS_OP_N #define HIPBLAS_STATUS_SUCCESS CUBLAS_STATUS_SUCCESS // Data types #define hipError_t cudaError_t #define hipStream_t cudaStream_t #define hipblasHandle_t cublasHandle_t #define hipblasStatus_t cublasStatus_t #define hipblasOperation_t cublasOperation_t #define hipGraph_t cudaGraph_t #define hipGraphNode_t cudaGraphNode_t #define hipGraphExec_t cudaGraphExec_t // Constants #define hipMemcpyHostToDevice cudaMemcpyHostToDevice #define hipMemcpyDeviceToHost cudaMemcpyDeviceToHost // Library calls #define hipblasCreate cublasCreate #define hipblasDestroy cublasDestroy #define hipblasDgemm cublasDgemm #define hipblasSgemm cublasSgemm #define hipblasDgemmBatched cublasDgemmBatched #define hipblasSgemmBatched cublasSgemmBatched #define hipblasDgemmStridedBatched cublasDgemmStridedBatched #define hipblasSgemmStridedBatched cublasSgemmStridedBatched #define hipblasSetStream cublasSetStream #define hipGraphExecDestroy cudaGraphExecDestroy #define hipGraphCreate cudaGraphCreate #define hipGraphDestroy cudaGraphDestroy #define hipGraphLaunch cudaGraphLaunch #define hipGraphInstantiate cudaGraphInstantiate #define hipGraphAddChildGraphNode cudaGraphAddChildGraphNode #define hipStreamCreate cudaStreamCreate #define hipStreamDestroy cudaStreamDestroy #define hipStreamCaptureModeGlobal cudaStreamCaptureModeGlobal #define hipStreamBeginCapture cudaStreamBeginCapture #define hipStreamEndCapture cudaStreamEndCapture // Runtime calls #define hipHostMalloc(PTR, SIZE, FLAGS) cudaMallocHost(PTR, SIZE) #define hipMalloc cudaMalloc #define hipFree cudaFree #define hipMemcpy cudaMemcpy #define hipDeviceSynchronize cudaDeviceSynchronize #define hipStreamSynchronize cudaStreamSynchronize #define hipMemGetInfo cudaMemGetInfo inline static const char * _blasGetErrorEnum(cublasStatus_t error) { switch (error) { case CUBLAS_STATUS_SUCCESS: return "CUBLAS_STATUS_SUCCESS"; case CUBLAS_STATUS_NOT_INITIALIZED: return "CUBLAS_STATUS_NOT_INITIALIZED"; case CUBLAS_STATUS_ALLOC_FAILED: return "CUBLAS_STATUS_ALLOC_FAILED"; case CUBLAS_STATUS_INVALID_VALUE: return "CUBLAS_STATUS_INVALID_VALUE"; case CUBLAS_STATUS_ARCH_MISMATCH: return "CUBLAS_STATUS_ARCH_MISMATCH"; case CUBLAS_STATUS_MAPPING_ERROR: return "CUBLAS_STATUS_MAPPING_ERROR"; case CUBLAS_STATUS_EXECUTION_FAILED: return "CUBLAS_STATUS_EXECUTION_FAILED"; case CUBLAS_STATUS_INTERNAL_ERROR: return "CUBLAS_STATUS_INTERNAL_ERROR"; } return ""; } #define HIC_CHECK(e) \ { \ cudaError_t err = (e); \ if (err != cudaSuccess) { \ fprintf(stderr, "CUDA error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ #e, cudaGetErrorString(err)); \ exit(EXIT_FAILURE); \ } \ } #define HICBLAS_CHECK(e) \ { \ cublasStatus_t err = (e); \ if (err != CUBLAS_STATUS_SUCCESS) { \ fprintf(stderr, "CUDA error: %s, line %d, %s: %s\n", __FILE__, __LINE__, \ #e, _blasGetErrorEnum(err)); \ exit(EXIT_FAILURE); \ } \ } #endif ectrans-1.8.0/src/trans/gpu/algor/hicblas.h0000664000175000017500000000237415174631767020765 0ustar alastairalastair // (C) Copyright 2000- ECMWF. // // 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. // HIC--->BLAS // hip // cuda // // Common header to provide abstraction layer to utilize hipblas and cublas from // common wrapper calls. Runtime and library specific implementations are pulled // in from bespoke header files. // #ifndef __HICBLAS_H__ #define __HICBLAS_H__ #ifdef HIPGPU #include "hicblas_hip.h" #elif defined(CUDAGPU) #include "hicblas_cuda.h" #endif inline void _printError(const char * component, const char * file, const int line, int err, const char * err_str) { fprintf(stderr, "%s error at 1\n", component); fprintf(stderr, "%s error in file '%s'\n", component, file); fprintf(stderr, "%s error at 2\n", component); fprintf(stderr, "%s error line '%d'\n", component, line); fprintf(stderr, "%s error at 3\n", component); fprintf(stderr, "%s error %d: %s\nterminating!\n", component, err, err_str); return; } #endif ectrans-1.8.0/src/trans/gpu/algor/c_hipmemgetinfo.cpp0000664000175000017500000000066415174631767023050 0ustar alastairalastair#include "hicblas.h" extern "C" { hipError_t c_hipmemgetinfo( int *meg_free, int *meg_total) { size_t l_free = 0; size_t l_total = 0; hipError_t error_memgetinfo; error_memgetinfo = hipMemGetInfo(&l_free, &l_total); long long ll_free = (long long) l_free; long long ll_total = (long long) l_total; *meg_free = (int) (ll_free / 1048576); *meg_total = (int) (ll_total / 1048576); return error_memgetinfo; } } ectrans-1.8.0/src/trans/gpu/algor/growing_allocator.h0000664000175000017500000000022615174631767023066 0ustar alastairalastair#pragma once extern "C" void growing_allocator_register_free_c(void *, void (&)(float *, size_t)); ectrans-1.8.0/src/trans/gpu/external/0000775000175000017500000000000015174631767017717 5ustar alastairalastairectrans-1.8.0/src/trans/gpu/external/dir_transad.F900000775000175000017500000004571215174631767022505 0ustar alastairalastair! (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 DIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANSAD* - Direct spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the direct spectral transform - adjoint !** Interface. ! ---------- ! CALL DIR_TRANSAD(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 resolution (input) ! PGP(:,:,:) - gridpoint fields (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIR_TRANS_CTLAD - control routine ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR, NOUT, LSYNC_TRANS USE TPM_TRANS, ONLY: LDIVGP, LSCDERS, LUVDER, LVORGP, LATLON, NF_SC2, NF_SC3A, NF_SC3B, & & NGPBLKS, NPROMA USE TPM_DISTR, ONLY: D, NPRTRV, MYSETV USE TPM_FLT, ONLY: S USE TPM_GEOMETRY, ONLY: G USE SET_RESOL_MOD, ONLY: SET_RESOL USE DIR_TRANS_CTLAD_MOD, ONLY: DIR_TRANS_CTLAD USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_BARRIER USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX !endif INTERFACE IMPLICIT NONE ! Declaration of arguments ! REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) ! REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) ! REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) ! REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) ! REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) ! REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) 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 REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: JMLOC, IF_PP ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIR_TRANSAD',0,ZHOOK_HANDLE) IF (LSYNC_TRANS) THEN CALL MPL_BARRIER(CDSTRING='') ENDIF CALL GSTATS(410,0) CALL GSTATS(1808,0) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT ! This is for use in TRGTOL which is shared with adjoint inverse transform LSCDERS=.FALSE. LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. LATLON=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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 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,*) 'DIR_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANS : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_TRANS: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,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1808,1) ! ------------------------------------------------------------------ CALL DIR_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(410,1) IF (LHOOK) CALL DR_HOOK('DIR_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE DIR_TRANSAD ectrans-1.8.0/src/trans/gpu/external/dir_trans.F900000775000175000017500000004552715174631767022204 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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 DIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & LDLATLON,KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANS* - Direct spectral transform (from grid-point to spectral). ! Purpose. ! -------- ! Interface routine for the direct spectral transform !** Interface. ! ---------- ! CALL DIR_TRANS(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! LDLATLON - indicating if regular lat-lon is the input data ! 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 resolution (input) ! PGP(:,:,:) - gridpoint fields (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - 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, LSYNC_TRANS USE TPM_TRANS, ONLY: LDIVGP, LSCDERS, LUVDER, LVORGP, LATLON, NF_SC2, NF_SC3A, NF_SC3B, & & NGPBLKS, NPROMA USE TPM_DISTR, ONLY: D, NPRTRV, MYSETV USE TPM_FLT, ONLY: S USE TPM_GEOMETRY, ONLY: G USE SET_RESOL_MOD, ONLY: SET_RESOL USE DIR_TRANS_CTL_MOD, ONLY: DIR_TRANS_CTL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE, ONLY: MPL_BARRIER USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX !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(:,:) 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 LOGICAL ,OPTIONAL, INTENT(IN) :: LDLATLON 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 variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: JMLOC, IF_PP ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIR_TRANS',0,ZHOOK_HANDLE) IF (LSYNC_TRANS) THEN CALL MPL_BARRIER(CDSTRING='') ENDIF CALL GSTATS(410,0) CALL GSTATS(1808,0) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT ! This is for use in TRGTOL which is shared with adjoint inverse transform LSCDERS=.FALSE. LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. LATLON=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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 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,*) 'DIR_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF IF(PRESENT(LDLATLON)) THEN LATLON = LDLATLON ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANS : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_TRANS: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,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1808,1) ! ------------------------------------------------------------------ CALL DIR_TRANS_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LSYNC_TRANS) THEN CALL GSTATS(430,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(430,1) ENDIF CALL GSTATS(410,1) IF (LHOOK) CALL DR_HOOK('DIR_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE DIR_TRANS ectrans-1.8.0/src/trans/gpu/external/specnorm.F900000775000175000017500000000707615174631767022042 0ustar alastairalastair! (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 SPECNORM(PNORM,PSPEC,KVSET,KMASTER,KRESOL,PMET) !**** *SPECNORM* - Compute global spectral norms ! Purpose. ! -------- ! Interface routine for computing spectral norms !** Interface. ! ---------- ! CALL SPECNORM(...) ! Explicit arguments : All arguments optional ! -------------------- ! PSPEC(:,:) - Spectral array ! KVSET(:) - "B-Set" for each field ! KMASTER - processor to recieve norms ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PMET(:) - metric ! PNORM(:) - Norms (output for processor KMASTER) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- SPNORM_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR USE TPM_DISTR, ONLY: D, NPRTRV, MYSETV, MYPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE SPNORM_CTL_MOD, ONLY: SPNORM_CTL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) , INTENT(OUT) :: PNORM(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE INTEGER(KIND=JPIM) :: IMASTER,IFLD,IFLD_G,J ! ------------------------------------------------------------------ ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults IMASTER = 1 IFLD = 0 IF(PRESENT(KMASTER)) THEN IMASTER = KMASTER ENDIF IF(PRESENT(KVSET)) THEN IFLD_G = UBOUND(KVSET,1) DO J=1,IFLD_G IF(KVSET(J) > NPRTRV) THEN WRITE(NERR,*) 'SPECNORM:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('SPECNORM:KVSET TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFLD = IFLD+1 ENDIF ENDDO ELSE IF(PRESENT(PSPEC)) THEN IFLD = UBOUND(PSPEC,1) ENDIF IFLD_G = IFLD ENDIF IF(NPRTRV >1) THEN IF(IFLD > 0 .AND. .NOT. PRESENT(KVSET)) THEN WRITE(NERR,*)'NPRTRV >1 AND IFLD > 0 AND NOT PRESENT(KVSET)',& &NPRTRV,IFLD CALL ABORT_TRANS('SPECNORM: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(MYPROC == IMASTER) THEN IF(UBOUND(PNORM,1) < IFLD_G) THEN CALL ABORT_TRANS('SPECNORM: PNORM TOO SMALL') ENDIF ENDIF IF(IFLD > 0 ) THEN IF(.NOT. PRESENT(PSPEC)) THEN CALL ABORT_TRANS('SPECNORM: PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,1) < IFLD) THEN CALL ABORT_TRANS('SPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,2) < D%NSPEC2) THEN CALL ABORT_TRANS('SPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL SPNORM_CTL(PNORM,PSPEC,IFLD,IFLD_G,KVSET,IMASTER,PMET) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE SPECNORM ectrans-1.8.0/src/trans/gpu/external/trans_release.F900000775000175000017500000000256015174631767023034 0ustar alastairalastair! (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 TRANS_RELEASE(KRESOL) !**** *TRANS_RELEASE* - release a spectral resolution ! Purpose. ! -------- ! Release all arrays related to a given resolution tag !** Interface. ! ---------- ! CALL TRANS_RELEASE ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM !ifndef INTERFACE USE DEALLOC_RESOL_MOD, ONLY: DEALLOC_RESOL ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL !endif INTERFACE ! ------------------------------------------------------------------ CALL DEALLOC_RESOL(KRESOL) ! ------------------------------------------------------------------ END SUBROUTINE TRANS_RELEASE ectrans-1.8.0/src/trans/gpu/external/trans_inq.F900000775000175000017500000004203215174631767022201 0ustar alastairalastair! (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 TRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& &KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& &KMYMS,KASM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& &KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& &KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& &KULTPP,KPTRLS,KNMENG,& &KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& &LDSPLITLAT,& &KSMAX,PLAPIN,KNVALUE,KDEF_RESOL,LDLAM,& &PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KDGLU) !**** *TRANS_INQ* - Extract information from the transform package ! Purpose. ! -------- ! Interface routine for extracting information from the T.P. !** Interface. ! ---------- ! CALL TRANS_INQ(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resolution (input) ! MULTI-TRANSFORMS MANAGEMENT ! KDEF_RESOL - number or resolutions defined ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! SPECTRAL SPACE ! KSPEC - number of complex spectral coefficients on this PE ! KSPEC2 - 2*KSPEC ! KSPEC2G - global KSPEC2 ! KSPEC2MX - maximun KSPEC2 among all PEs ! KNUMP - Number of spectral waves handled by this PE ! KGPTOT - Total number of grid columns on this PE ! KGPTOTG - Total number of grid columns on the Globe ! KGPTOTMX - Maximum number of grid columns on any of the PEs ! KGPTOTL - Number of grid columns one each PE (dimension N_REGIONS_NS:N_REGIONS_EW) ! KMYMS - This PEs spectral zonal wavenumbers ! KASM0 - Address in a spectral array of (m, n=m) ! KUMPP - No. of wave numbers each wave set is responsible for ! KPOSSP - Defines partitioning of global spectral fields among PEs ! KPTRMS - Pointer to the first wave number of a given a-set ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KSMAX - spectral truncation ! KNVALUE - n value for each KSPEC2 spectral coeffient ! GRIDPOINT SPACE ! KFRSTLAT - First latitude of each a-set in grid-point space ! KLSTTLAT - Last latitude of each a-set in grid-point space ! KFRSTLOFF - Offset for first lat of own a-set in grid-point space ! KPTRLAT - Pointer to the start of each latitude ! KPTRFRSTLAT - Pointer to the first latitude of each a-set in ! NSTA and NONL arrays ! KPTRLSTLAT - Pointer to the last latitude of each a-set in ! NSTA and NONL arrays ! KPTRFLOFF - Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 ! KSTA - Position of first grid column for the latitudes on a ! processor. The information is available for all processors. ! The b-sets are distinguished by the last dimension of ! nsta().The latitude band for each a-set is addressed by ! nptrfrstlat(jaset),nptrlstlat(jaset), and ! nptrfloff=nptrfrstlat(myseta) on this processors a-set. ! Each split latitude has two entries in nsta(,:) which ! necessitates the rather complex addressing of nsta(,:) ! and the overdimensioning of nsta by N_REGIONS_NS. ! KONL - Number of grid columns for the latitudes on a processor. ! Similar to nsta() in data structure. ! LDSPLITLAT - TRUE if latitude is split in grid point space over ! two a-sets ! FOURIER SPACE ! KULTPP - number of latitudes for which each a-set is calculating ! the FFT's. ! KPTRLS - pointer to first global latitude of each a-set for which ! it performs the Fourier calculations ! KNMENG - associated (with NLOENG) cut-off zonal wavenumber ! LEGENDRE ! PMU - sin(Gaussian latitudes) ! PGW - Gaussian weights ! PRPNM - Legendre polynomials ! KLEI3 - First dimension of Legendre polynomials ! KSPOLEGL - Second dimension of Legendre polynomials ! KPMS - Adress for legendre polynomial for given M (NSMAX) ! PLAPIN - Eigen-values of the inverse Laplace operator ! KDGLU - Number of active points in an hemisphere for a given wavenumber "m" ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M. Hortal : 2001-03-05 Dimensions of the Legendre polynomials ! R. El Khatib 08-Aug-2012 KSMAX,PLAPIN,KNVALUE,LDLAM,KDEF_RESOL ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB, JPRD !ifndef INTERFACE USE TPM_GEN, ONLY: NDEF_RESOL USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D, NPRTRNS, NPRTRW, MYSETV, MYSETW, NPRTRV USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS, ONLY: F USE TPM_FLT, ONLY: S USE SET_RESOL_MOD, ONLY: SET_RESOL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE EQ_REGIONS_MOD, ONLY: MY_REGION_EW, MY_REGION_NS, N_REGIONS_EW, N_REGIONS_NS !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2MX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNUMP INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOT INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTG INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTMX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTL(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KFRSTLOFF INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRFLOFF INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KASM0(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KUMPP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPOSSP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KALLMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDIM0G(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KLSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSTA(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KONL(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW LOGICAL ,OPTIONAL, INTENT(OUT) :: LDSPLITLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KULTPP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNMENG(:) REAL(KIND=JPRD) ,OPTIONAL, INTENT(OUT) :: PMU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGW(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PRPNM(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KLEI3 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPOLEGL INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPMS(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDGLU(0:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PLAPIN(-1:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM !ifndef INTERFACE INTEGER(KIND=JPIM) :: IU1,IU2 INTEGER(KIND=JPIM) :: IC, JN, JMLOC INTEGER(KIND=JPIM) :: IPRTRV,JSETV,IMLOC,IM,ISL,IA,ILA,IS,ILS,IDGLU,J,I ! ------------------------------------------------------------------ ! Set current resolution CALL SET_RESOL(KRESOL) IF(PRESENT(KSPEC)) KSPEC = D%NSPEC IF(PRESENT(KSPEC2)) KSPEC2 = D%NSPEC2 IF(PRESENT(KSPEC2G)) KSPEC2G = R%NSPEC2_G IF(PRESENT(KSPEC2MX)) KSPEC2MX = D%NSPEC2MX IF(PRESENT(KNUMP)) KNUMP = D%NUMP IF(PRESENT(KGPTOT)) KGPTOT = D%NGPTOT IF(PRESENT(KGPTOTG)) KGPTOTG = D%NGPTOTG IF(PRESENT(KGPTOTMX)) KGPTOTMX = D%NGPTOTMX IF(PRESENT(KFRSTLOFF)) KFRSTLOFF = D%NFRSTLOFF IF(PRESENT(KPTRFLOFF)) KPTRFLOFF = D%NPTRFLOFF IF(PRESENT(KPTRFLOFF)) KPTRFLOFF = D%NPTRFLOFF IF(PRESENT(KPRTRW)) KPRTRW = NPRTRW IF(PRESENT(KMYSETW)) KMYSETW = MYSETW IF(PRESENT(KMYSETV)) KMYSETV = MYSETV IF(PRESENT(KMY_REGION_NS)) KMY_REGION_NS = MY_REGION_NS IF(PRESENT(KMY_REGION_EW)) KMY_REGION_EW = MY_REGION_EW IF(PRESENT(LDLAM)) LDLAM = G%LAM IF(PRESENT(KDEF_RESOL)) KDEF_RESOL = NDEF_RESOL IF(PRESENT(KGPTOTL)) THEN IF(UBOUND(KGPTOTL,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KGPTOTL DIM 1 TOO SMALL') ELSEIF(UBOUND(KGPTOTL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('TRANS_INQ: KGPTOTL DIM 2 TOO SMALL') ELSE KGPTOTL(1:N_REGIONS_NS,1:N_REGIONS_EW) = D%NGPTOTL(:,:) ENDIF ENDIF IF(PRESENT(KMYMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KMYMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KMYMS,1) < D%NUMP) THEN CALL ABORT_TRANS('TRANS_INQ: KMYMS TOO SMALL') ELSE KMYMS(1:D%NUMP) = D%MYMS(:) ENDIF ENDIF IF(PRESENT(KASM0)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KASM0 REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KASM0,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KASM0 TOO SMALL') ELSE KASM0(0:R%NSMAX) = D%NASM0(:) ENDIF ENDIF IF(PRESENT(KUMPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KUMPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KUMPP,1) < NPRTRW) THEN CALL ABORT_TRANS('TRANS_INQ: KUMPP TOO SMALL') ELSE KUMPP(1:NPRTRW) = D%NUMPP(:) ENDIF ENDIF IF(PRESENT(KPOSSP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPOSSP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPOSSP,1) < NPRTRW+1) THEN CALL ABORT_TRANS('TRANS_INQ: KPOSSP TOO SMALL') ELSE KPOSSP(1:NPRTRW+1) = D%NPOSSP(:) ENDIF ENDIF IF(PRESENT(KPTRMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRMS,1) < NPRTRW) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRMS TOO SMALL') ELSE KPTRMS(1:NPRTRW) = D%NPTRMS(:) ENDIF ENDIF IF(PRESENT(KALLMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KALLMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KALLMS,1) < R%NSMAX+1) THEN CALL ABORT_TRANS('TRANS_INQ: KALLMS TOO SMALL') ELSE KALLMS(1:R%NSMAX+1) = D%NALLMS(:) ENDIF ENDIF IF(PRESENT(KDIM0G)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KDIM0G REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KDIM0G,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KDIM0G TOO SMALL') ELSE KDIM0G(0:R%NSMAX) = D%NDIM0G(0:R%NSMAX) ENDIF ENDIF IF(PRESENT(KFRSTLAT)) THEN IF(UBOUND(KFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KFRSTLAT TOO SMALL') ELSE KFRSTLAT(1:N_REGIONS_NS) = D%NFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KLSTLAT)) THEN IF(UBOUND(KLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KLSTLAT TOO SMALL') ELSE KLSTLAT(1:N_REGIONS_NS) = D%NLSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLAT)) THEN IF(UBOUND(KPTRLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLAT TOO SMALL') ELSE KPTRLAT(1:R%NDGL) = D%NPTRLAT(:) ENDIF ENDIF IF(PRESENT(KPTRFRSTLAT)) THEN IF(UBOUND(KPTRFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRFRSTLAT TOO SMALL') ELSE KPTRFRSTLAT(1:N_REGIONS_NS) = D%NPTRFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLSTLAT)) THEN IF(UBOUND(KPTRLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLSTLAT TOO SMALL') ELSE KPTRLSTLAT(1:N_REGIONS_NS) = D%NPTRLSTLAT(:) ENDIF ENDIF IF(PRESENT(KSTA)) THEN IF(UBOUND(KSTA,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('TRANS_INQ: KSTA DIM 1 TOO SMALL') ELSEIF(UBOUND(KSTA,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('TRANS_INQ: KSTA DIM 2 TOO SMALL') ELSE KSTA(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NSTA(:,:) ENDIF ENDIF IF(PRESENT(KONL)) THEN IF(UBOUND(KONL,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('TRANS_INQ: KONL DIM 1 TOO SMALL') ELSEIF(UBOUND(KONL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('TRANS_INQ: KONL DIM 2 TOO SMALL') ELSE KONL(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NONL(:,:) ENDIF ENDIF IF(PRESENT(LDSPLITLAT)) THEN IF(UBOUND(LDSPLITLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: LDSPLITLAT TOO SMALL') ELSE LDSPLITLAT(1:R%NDGL) = D%LSPLITLAT(:) ENDIF ENDIF IF(PRESENT(KULTPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KULTPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KULTPP,1) < NPRTRNS) THEN CALL ABORT_TRANS('TRANS_INQ: KULTPP TOO SMALL') ELSE KULTPP(1:NPRTRNS) = D%NULTPP(:) ENDIF ENDIF IF(PRESENT(KPTRLS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRLS,1) < NPRTRNS) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLS TOO SMALL') ELSE KPTRLS(1:NPRTRNS) = D%NPTRLS(:) ENDIF ENDIF IF(PRESENT(KNMENG)) THEN IF(UBOUND(KNMENG,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: KNMENG TOO SMALL') ELSE KNMENG(1:R%NDGL) = G%NMEN(1:R%NDGL) ENDIF ENDIF IF(PRESENT(PMU)) THEN IF(UBOUND(PMU,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: PMU TOO SMALL') ELSE PMU(1:R%NDGL) = F%RMU ENDIF ENDIF IF(PRESENT(PGW)) THEN IF(UBOUND(PGW,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: PGW TOO SMALL') ELSE PGW(1:R%NDGL) = REAL(F%RW,JPRB) ENDIF ENDIF IF(PRESENT(PRPNM)) THEN IF( .NOT. S%LKEEPRPNM ) THEN CALL ABORT_TRANS('TRANS_INQ: PRPNM REQUIRED BUT S%LKEEPRPNM=F') ENDIF IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: PRPNM REQUIRED BUT LGRIDONLY=T') ENDIF IU1 = UBOUND(PRPNM,1) IU2 = UBOUND(PRPNM,2) IF(IU1 < R%NDGNH) THEN CALL ABORT_TRANS('TRANS_INQ:FIRST DIM. OF PRNM TOO SMALL') ELSE ! IU1 = MIN(IU1,R%NLEI3) ! IU2 = MIN(IU2,D%NSPOLEGL) ! PRPNM(1:IU1,1:IU2) = F%RPNM(1:IU1,1:IU2) DO JMLOC=1,D%NUMP,NPRTRV IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) DO J=1,ILA DO I=1,IDGLU PRPNM(ISL+I-1,D%NPMS(IM)+IA+(J-1)*2) = REAL(S%FA(IMLOC)%RPNMA(I,J),JPRB) ENDDO ENDDO DO J=1,ILS DO I=1,IDGLU PRPNM(ISL+I-1,D%NPMS(IM)+IS+(J-1)*2) = REAL(S%FA(IMLOC)%RPNMS(I,J),JPRB) ENDDO ENDDO ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KLEI3)) THEN KLEI3=R%NLEI3 ENDIF IF(PRESENT(KSPOLEGL)) THEN KSPOLEGL=D%NSPOLEGL ENDIF IF(PRESENT(KPMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPMS,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KPMS TOO SMALL') ELSE KPMS(0:R%NSMAX) = D%NPMS(0:R%NSMAX) ENDIF ENDIF IF(PRESENT(KSMAX)) KSMAX = R%NSMAX IF(PRESENT(PLAPIN)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: PLAPIN REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(PLAPIN,1) < R%NSMAX+2) THEN CALL ABORT_TRANS('TRANS_INQ: PLAPIN TOO SMALL') ELSEIF (LBOUND(PLAPIN,1) /= -1) THEN CALL ABORT_TRANS('TRANS_INQ: LOWER BOUND OF PLAPIN SHOULD BE -1') ELSE PLAPIN(-1:R%NSMAX+2) = REAL(F%RLAPIN(:),JPRB) ENDIF ENDIF IF(PRESENT(KNVALUE)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') ENDIF IF(SIZE(KNVALUE) < D%NSPEC2) THEN CALL ABORT_TRANS('TRANS_INQ: KNVALUE TOO SMALL') ELSE IC=1 DO JMLOC=1,D%NUMP DO JN=D%MYMS(JMLOC),R%NSMAX KNVALUE(IC )=JN KNVALUE(IC+1)=JN IC=IC+2 ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KDGLU)) THEN IF(UBOUND(KDGLU,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KDGLU TOO SMALL') ELSE KDGLU(0:R%NSMAX) = G%NDGLU(0:R%NSMAX) ENDIF ENDIF ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE TRANS_INQ ectrans-1.8.0/src/trans/gpu/external/gpnorm_trans_gpu.F900000775000175000017500000003311115174631767023565 0ustar alastairalastair! (C) Copyright 2008- ECMWF. ! (C) Copyright 2008- 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 GPNORM_TRANS_GPU(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !**** *GPNORM_TRANS_GPU* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL GPNORM_TRANS(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! Modifications. ! -------------- ! Original : 19th Sept 2008 ! R. El Khatib 07-08-2009 Optimisation directive for NEC ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB, JPRD USE PARKIND_ECTRANS, ONLY: JPRBT !ifndef INTERFACE USE TPM_GEN, ONLY: NOUT USE TPM_DIM, ONLY: R USE TPM_TRANS, ONLY: LGPNORM, NGPBLKS, NPROMA USE TPM_DISTR, ONLY: D, NPRCIDS, NPRTRV, NPRTRW, MYSETV, MYSETW, NPROC USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS, ONLY: F USE SET_RESOL_MOD, ONLY: SET_RESOL USE TRGTOL_MOD, ONLY: TRGTOL USE SET2PE_MOD, ONLY: SET2PE USE MPL_MODULE, ONLY: MPL_RECV, MPL_SEND, JP_BLOCKING_STANDARD USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL ,INTENT(IN) :: LDAVE_ONLY INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IUBOUND(4) INTEGER(KIND=JPIM) :: IVSET(KFIELDS) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETG(:,:) !GPU REAL(KIND=JPRBT) :: V REAL(KIND=JPRBT),ALLOCATABLE,SAVE :: ZGTF(:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGL(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGL(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMIN(:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMAX(:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGPN(:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGPN(:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVEG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZMING(:) REAL(KIND=JPRB),ALLOCATABLE :: ZMAXG(:) REAL(KIND=JPRD),ALLOCATABLE :: ZSND(:) REAL(KIND=JPRD),ALLOCATABLE :: ZRCV(:) INTEGER(KIND=JPIM) :: J,JGL,IGL,JL,JF,IF_GP,IF_SCALARS_G,IF_FS,JSETV,JSETW,IWLATS,JMAX INTEGER(KIND=JPIM) :: IPROC,ITAG,ILEN,ILENR,IBEG,IEND,IND !INTEGER(KIND=JPIM) :: iunit ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults NPROMA = KPROMA NGPBLKS = (D%NGPTOT-1)/NPROMA+1 ! Consistency checks IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'GPNORM_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('GPNORM_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFIELDS) THEN WRITE(NOUT,*)'GPNORM_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFIELDS CALL ABORT_TRANS('GPNORM_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'GPNORM_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('GPNORM_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF_GP=KFIELDS IF_SCALARS_G=0 IF_FS=0 DO J=1,KFIELDS IVSET(J)=MOD(J-1,NPRTRV)+1 IF(IVSET(J)==MYSETV)THEN IF_FS=IF_FS+1 ENDIF ENDDO IF (.NOT. ALLOCATED(ZAVE)) THEN ALLOCATE(ZAVE(IF_FS,R%NDGL)) ALLOCATE(ZMINGL(IF_FS,R%NDGL)) ALLOCATE(ZMAXGL(IF_FS,R%NDGL)) ALLOCATE(ZMINGPN(IF_FS)) ALLOCATE(ZMAXGPN(IF_FS)) ZAVE = 0._JPRBT ZMINGL = 0._JPRBT ZMAXGL = 0._JPRBT ZMINGPN = 0._JPRBT ZMAXGPN = 0._JPRBT #ifdef ACCGPU !$ACC ENTER DATA COPYIN(ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) #endif #ifdef OMPGPU !$OMP TARGET ENTER DATA MAP(TO:ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) #endif IF (.NOT. ALLOCATED(ZGTF)) THEN ALLOCATE(ZGTF(IF_FS*D%NLENGTF)) WRITE(NOUT,*)'ZGTF :',SIZE(ZGTF) #ifdef ACCGPU !$ACC ENTER DATA CREATE(ZGTF) #endif #ifdef OMPGPU !$OMP TARGET ENTER DATA MAP(ALLOC:ZGTF) #endif ENDIF ENDIF ALLOCATE(IVSETS(NPRTRV)) IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 ENDDO ALLOCATE(IVSETG(NPRTRV,MAXVAL(IVSETS(:)))) IVSETG(:,:)=0 IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 IVSETG(IVSET(J),IVSETS(IVSET(J)))=J ENDDO ! done in setup_trans LGPNORM=.TRUE. !!FIXME !!CALL TRGTOL_CUDAAWARE(ZGTF,IF_FS,IF_GP,IVSET,PGP=PGP) LGPNORM=.FALSE. ! ZGTF is now on GPU IBEG=1 IEND=D%NDGL_FS ASSOCIATE(D_NSTAGTF=>D%NSTAGTF,D_NPTRLS=>D%NPTRLS,G_NLOEN=>G%NLOEN,F_RW=>F%RW) CALL GSTATS(1429,0) IF( IF_FS > 0 )THEN #ifdef ACCGPU !$ACC DATA & !$ACC& COPY(D,D_NSTAGTF,D_NPTRLS,G_NLOEN,F,F_RW) & !$ACC& PRESENT(ZGTF,ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) !$ACC KERNELS #endif #ifdef OMPGPU !$OMP TARGET DATA MAP(TO:F,D,D_NSTAGTF,D_NPTRLS,G_NLOEN) & !$OMP& MAP(PRESENT,ALLOC:ZGTF,ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO & !$OMP& PRIVATE(V) #endif DO JF=1,IF_FS V = ZGTF(IF_FS*D_NSTAGTF(1)+(JF-1)*(D%NSTAGTF(2)-D%NSTAGTF(1))) ZMINGL(JF,IBEG:IEND)=HUGE(1_JPRBT) ZMAXGL(JF,IBEG:IEND)=-HUGE(1_JPRBT) ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif ! FIRST DO SUMS IN EACH FULL LATITUDE #ifdef ACCGPU !$ACC KERNELS #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO & !$OMP& PRIVATE(IGL,V) #endif DO JGL=1,D%NDGL_FS IGL = D_NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=0.0_JPRBT #ifdef ACCGPU !$ACC LOOP #endif DO JL=1,G_NLOEN(IGL) V = ZGTF(IF_FS*D%NSTAGTF(JGL)+(JF-1)*(D%NSTAGTF(JGL+1)-D%NSTAGTF(JGL))+JL) ZAVE(JF,JGL)=ZAVE(JF,JGL)+V ZMINGL(JF,JGL)=MIN(ZMINGL(JF,JGL),V) ZMAXGL(JF,JGL)=MAX(ZMAXGL(JF,JGL),V) ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif #ifdef ACCGPU !$ACC KERNELS #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO #endif DO JF=1,IF_FS ZMINGPN(JF)=MINVAL(ZMINGL(JF,IBEG:IEND)) ZMAXGPN(JF)=MAXVAL(ZMAXGL(JF,IBEG:IEND)) ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif #ifdef ACCGPU !$ACC KERNELS #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO & !$OMP& PRIVATE(IGL) #endif DO JGL=IBEG,IEND IGL = D_NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=ZAVE(JF,JGL)*F_RW(IGL)/G_NLOEN(IGL) !write(iunit,*) 'aver inside ',JF,IF_FS,IGL,ZAVE(JF,JGL), F%RW(IGL), G_NLOEN(IGL),ZMINGPN(JF),ZMAXGPN(JF) ENDDO ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif #ifdef ACCGPU !$ACC UPDATE HOST(ZAVE) #endif #ifdef OMPGPU !$OMP TARGET UPDATE FROM(ZAVE) #endif #ifdef ACCGPU !$ACC UPDATE HOST(ZMINGPN) #endif #ifdef OMPGPU !$OMP TARGET UPDATE FROM(ZMINGPN) #endif #ifdef ACCGPU !$ACC UPDATE HOST(ZMAXGPN) #endif #ifdef OMPGPU !$OMP TARGET UPDATE FROM(ZMAXGPN) #endif #ifdef ACCGPU !$ACC WAIT #endif #ifdef OMPGPU !$OMP BARRIER #endif ENDIF CALL GSTATS(1429,1) END ASSOCIATE ! from here rest on CPU ! IT IS IMPORTANT THAT SUMS ARE NOW DONE IN LATITUDE ORDER ALLOCATE(ZAVEG(R%NDGL,KFIELDS)) ALLOCATE(ZMING(KFIELDS)) ALLOCATE(ZMAXG(KFIELDS)) ZAVEG(:,:)=0.0_JPRD DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 ZAVEG(IGL,IVSETG(MYSETV,JF))=ZAVEG(IGL,IVSETG(MYSETV,JF))+ZAVE(JF,JGL) ENDDO ENDDO IF(LDAVE_ONLY)THEN ZMING(:)=PMIN(:) ZMAXG(:)=PMAX(:) ELSE DO JF=1,IF_FS ZMING(IVSETG(MYSETV,JF))=ZMINGPN(JF) ZMAXG(IVSETG(MYSETV,JF))=ZMAXGPN(JF) ENDDO ENDIF ! RECEIVE ABOVE FROM OTHER NPRTRV SETS FOR SAME LATS BUT DIFFERENT FIELDS ITAG=123 CALL GSTATS(815,0) IF( MYSETV==1 )THEN DO JSETV=2,NPRTRV IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*IVSETS(JSETV)+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*IVSETS(JSETV) ENDIF IF(ILEN > 0)THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,MYSETW,JSETV) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS:V') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS:ILENR /= ILEN') ENDIF IND=0 DO JF=1,IVSETS(JSETV) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,IVSETG(JSETV,JF))=ZRCV(IND) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZMING(IVSETG(JSETV,JF))=ZRCV(IND) IND=IND+1 ZMAXG(IVSETG(JSETV,JF))=ZRCV(IND) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),JPRB)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),JPRB)) ENDDO ENDIF DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*IVSETS(MYSETV)+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*IVSETS(MYSETV) ENDIF IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,MYSETW,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,IVSETG(MYSETV,JF)) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZSND(IND)=ZMING(IVSETG(MYSETV,JF)) IND=IND+1 ZSND(IND)=ZMAXG(IVSETG(MYSETV,JF)) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZSND(IND)=PMIN(JF) IND=IND+1 ZSND(IND)=PMAX(JF) ENDDO ENDIF CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS:V') DEALLOCATE(ZSND) ENDIF ENDIF ! FINALLY RECEIVE CONTRIBUTIONS FROM OTHER NPRTRW SETS IF( MYSETV == 1 )THEN IF( MYSETW == 1 )THEN DO JSETW=2,NPRTRW IWLATS=D%NULTPP(JSETW) IBEG=1 IEND=IWLATS IF(LDAVE_ONLY)THEN ILEN=IWLATS*KFIELDS+2*KFIELDS ELSE ILEN=(IWLATS+2)*KFIELDS ENDIF IF(ILEN > 0 )THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,JSETW,1) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS:W') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS:ILENR /= ILEN') ENDIF IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IEND IGL = D%NPTRLS(JSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,JF)=ZRCV(IND) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),JPRBT)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),JPRBT)) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),JPRBT)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),JPRBT)) ENDDO ENDIF DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*KFIELDS+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*KFIELDS ENDIF IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,1,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,JF) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZSND(IND)=ZMING(JF) IND=IND+1 ZSND(IND)=ZMAXG(JF) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZSND(IND)=ZMING(JF) IND=IND+1 ZSND(IND)=ZMAXG(JF) ENDDO ENDIF CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS:V') DEALLOCATE(ZSND) ENDIF ENDIF ENDIF CALL GSTATS(815,1) IF( MYSETW == 1 .AND. MYSETV == 1 )THEN PAVE(:)=0.0_JPRB DO JGL=1,R%NDGL PAVE(:)=PAVE(:)+REAL(ZAVEG(JGL,:),JPRB) ENDDO PMIN(:)=ZMING(:) PMAX(:)=ZMAXG(:) ENDIF !DEALLOCATE(ZGTF) !DEALLOCATE(ZAVE) !DEALLOCATE(ZMIN) !DEALLOCATE(ZMAX) DEALLOCATE(ZAVEG) DEALLOCATE(ZMING) DEALLOCATE(ZMAXG) DEALLOCATE(IVSETS) DEALLOCATE(IVSETG) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANS_GPU ectrans-1.8.0/src/trans/gpu/external/gpnorm_transtl.F900000775000175000017500000000453215174631767023257 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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 GPNORM_TRANSTL(PGP,KFIELDS,KPROMA,PAVE,KRESOL) !**** *GPNORM_TRANSTL* - calculate grid-point norms ! reduced version for linear model ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL GPNORM_TRANSTL(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! Filip Vana, (c) ECMWF ! 9-Sep-2024 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE ABORT_TRANS_MOD, ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSTL',0,ZHOOK_HANDLE) CALL ABORT_TRANS("GPNORM_TRANSTL not implemented yet for GPUs") IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANSTL ectrans-1.8.0/src/trans/gpu/external/gath_spec.F900000775000175000017500000001325215174631767022142 0ustar alastairalastair! (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 GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LDZA0IP) !**** *GATH_SPEC* - Gather global spectral array from processors ! Purpose. ! -------- ! Interface routine for gathering spectral array !** Interface. ! ---------- ! CALL GATH_SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for gathering each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PSPEC(:,:) - Local spectral array ! LDZA0IP - Set to zero imaginary part of first coefficients ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! Modified 03-09-30 Y. Seity, bug correction IFSEND=0 ! Modified 13-10-10 P. Marguinaud add LDZA0IP option ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D, NPRTRV, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE GATH_SPEC_CONTROL_MOD, ONLY: GATH_SPEC_CONTROL USE SUWAVEDI_MOD, ONLY: SUWAVEDI 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) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFGATHG) INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J INTEGER(KIND=JPIM) :: IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GATH_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) LLDIM1_IS_FLD = .TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD = 1 ICOEFF = 2 ELSE IFLD = 2 ICOEFF = 1 ENDIF IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_SPEC: KTO TOO SHORT!') ENDIF ISMAX = R%NSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX ALLOCATE(IDIM0G(0:ISMAX)) IF(ISMAX /= R%NSMAX) THEN CALL SUWAVEDI(ISMAX,ISMAX,NPRTRW,MYSETW,KPOSSP=IPOSSP,KSPEC2=ISPEC2,& & KDIM0G=IDIM0G) ISPEC2_G = (ISMAX+1)*(ISMAX+2) ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_SPEC:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_SPEC:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('GATH_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFRECV) THEN WRITE(NERR,*) 'GATH_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFRECV CALL ABORT_TRANS('GATH_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'GATH_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('GATH_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFGATHG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'GATH_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('GATH_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFSEND = IFSEND+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFGATHG) ELSEIF(NPRTRV > 1) THEN WRITE(NERR,*) 'GATH_SPEC:KVSET MISSING, NPRTRV ',NPRTRV CALL ABORT_TRANS('GATH_SPEC:KVSET MISSING, NPRTRV > 1') ELSE IFSEND = KFGATHG IVSET(:) = 1 ENDIF IF(IFSEND > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('GATH_SPEC: FIELDS TO RECIEVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFSEND) THEN CALL ABORT_TRANS('GATH_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('GATH_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,& & ISMAX,ISPEC2,ISPEC2_G,IPOSSP,IDIM0G,LDZA0IP) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('GATH_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE GATH_SPEC ectrans-1.8.0/src/trans/gpu/external/gpnorm_transad.F900000775000175000017500000000451415174631767023224 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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 GPNORM_TRANSAD(PGP,KFIELDS,KPROMA,PAVE,KRESOL) !**** *GPNORM_TRANSAD* - calculate grid-point norms ! (adjoint version) ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL GPNORM_TRANSAD(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! Filip Vana ! (c) ECMWF 14-Aug-2024 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE ABORT_TRANS_MOD, ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSAD',0,ZHOOK_HANDLE) CALL ABORT_TRANS("GPNORM_TRANSAD not implemented yet for GPUs") IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANSAD ectrans-1.8.0/src/trans/gpu/external/dist_grid_32.F900000775000175000017500000001000715174631767022454 0ustar alastairalastair! (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 DIST_GRID_32(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP) !**** *DIST_GRID_32* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID_32(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_GRID_32_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRM !ifndef INTERFACE USE TPM_GEN, ONLY: NERR, NOUT USE TPM_DISTR, ONLY: D, NPROC, MYPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE DIST_GRID_32_CTL_MOD, ONLY: DIST_GRID_32_CTL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRM) , INTENT(OUT) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIST_GRID_32',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_GRID_32: KFROM TOO SHORT!') ENDIF IFSEND = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'DIST_GRID_32:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('DIST_GRID_32:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'DIST_GRID_32:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('DIST_GRID_32:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFDISTG) THEN WRITE(NOUT,*)'DIST_GRID_32:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFDISTG CALL ABORT_TRANS('DIST_GRID_32:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'DIST_GRID_32:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('DIST_GRID_32:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('DIST_GRID_32:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('DIST_GRID_32:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFSEND) THEN CALL ABORT_TRANS('DIST_GRID_32:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL DIST_GRID_32_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP) IF (LHOOK) CALL DR_HOOK('DIST_GRID_32',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID_32 ectrans-1.8.0/src/trans/gpu/external/setup_trans.F900000775000175000017500000004716715174631767022570 0ustar alastairalastair#define ALIGN(I, A) (((I)+(A)-1)/(A)*(A)) ! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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 SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& & KTMAX,KRESOL,PWEIGHT,LDGRIDONLY,LDUSERPNM,LDKEEPRPNM,LDUSEFLT,& & LDSPSETUPONLY,LDPNMONLY,LDUSEFFTW,LD_ALL_FFTW,& & LDLL,LDSHIFTLL,CDIO_LEGPOL,CDLEGPOLFNAME,KLEGPOLPTR,KLEGPOLPTR_LEN) !**** *SETUP_TRANS* - Setup transform package for specific resolution ! Purpose. ! -------- ! To setup for making spectral transforms. Each call to this routine ! creates a new resolution up to a maximum of NMAX_RESOL set up in ! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can ! be called. !** Interface. ! ---------- ! CALL SETUP_TRANS(...) ! Explicit arguments : KLOEN,LDSPLIT are optional arguments ! -------------------- ! KSMAX - spectral truncation required ! KDGL - number of Gaussian latitudes ! KDLON - number of points on each Gaussian latitude [2*KDGL] ! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] ! LDSPLIT - true if split latitudes in grid-point space [false] ! KTMAX - truncation order for tendencies? ! KRESOL - the resolution identifier ! PWEIGHT - the weight per grid-point (for a weighted distribution); ! Note, only seems to be used from within enkf ! LDGRIDONLY - true if only grid space is required ! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution ! in spectral and grid-point space ! LDSPLIT describe the distribution among processors of grid-point data and ! has no relevance if you are using a single processor ! PSTRET - stretching factor - for the case the Legendre polynomials are ! computed on the stretched sphere - works with LSOUTHPNM ! LDUSEFLT - use Fast Legandre Transform (Butterfly algorithm) ! LDUSERPNM - Use Belusov algorithm to compute legendre pol. (else new alg.) ! LDKEEPRPNM - Keep Legendre Polynomials (only applicable when using ! FLT, otherwise always kept) ! LDPNMONLY - Compute the Legendre polynomials only, not the FFTs. ! LDUSEFFTW - Use FFTW for FFTs (option deprecated - FFTW is now mandatory) ! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another ! LDLL - Setup second set of input/output latitudes ! the number of input/output latitudes to transform is equal KDGL ! or KDGL+2 in the case that includes poles + equator ! the number of input/output longitudes to transform is 2*KDGL ! LDSHIFTLL - Shift output lon/lat data by 0.5*dx and 0.5*dy ! CDIO_LEGPOL - IO option on Legendre polinomials : N.B. Only works for NPROC=1 ! Options: ! 'READF' - read Leg.Pol. from file CDLEGPOLFNAME ! 'WRITEF' - write Leg.Pol. to file CDLEGPOLFNAME ! 'MEMBUF' - Leg. Pol provided in shared memory segment pointed to by KLEGPOLPTR of ! length KLEGPOLPTR_LEN ! CDLEGPOLFNAME - file name for Leg.Pol. IO ! KLEGPOLPTR - pointer to Legendre polynomials memory segment ! KLEGPOLPTR_LEN - length of Legendre polynomials memory segment ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- SETUP_DIMS - setup distribution independent dimensions ! SUMP_TRANS_PRELEG - first part of setup of distr. environment ! SULEG - Compute Legandre polonomial and Gaussian ! Latitudes and Weights ! SUMP_TRANS - Second part of setup of distributed environment ! SHAREDMEM_CREATE - create memory buffer for Leg.pol. ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! Daan Degrauwe : Mar 2012 E'-zone dimensions ! R. El Khatib 09-Aug-2012 %LAM in GEOM_TYPE ! R. El Khatib 14-Jun-2013 PSTRET, LDPNMONLY, LENABLED ! G. Mozdzynski : Oct 2014 Support f ! N. Wedi : Apr 2015 Support dual set of lat/lon ! G. Mozdzynski : Jun 2015 Support alternative FFTs to FFTW ! M.Hamrud/W.Deconinck : July 2015 IO options for Legenndre polynomials ! R. El Khatib 07-Mar-2016 Better flexibility for Legendre polynomials computation in stretched mode ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB, JPRD, JPIB USE PARKIND_ECTRANS, ONLY: JPRBT !ifndef INTERFACE USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_ASSOCIATED, C_SIZE_T, C_SIZEOF, C_LOC, C_F_POINTER USE TPM_GEN, ONLY: NOUT, MSETUP0, NCUR_RESOL, NDEF_RESOL, & & NMAX_RESOL, NPRINTLEV, LENABLED, NERR USE TPM_DIM, ONLY: R, DIM_RESOL USE TPM_DISTR, ONLY: D, DISTR_RESOL, NPROC, MYPROC USE TPM_GEOMETRY, ONLY: G, GEOM_RESOL USE TPM_FIELDS, ONLY: FIELDS_RESOL, F USE TPM_FIELDS_GPU, ONLY: FIELDS_GPU_RESOL, FG USE TPM_FLT, ONLY: FLT_RESOL, S USE TPM_CTL, ONLY: CTL_RESOL, C USE SET_RESOL_MOD, ONLY: SET_RESOL USE SETUP_DIMS_MOD, ONLY: SETUP_DIMS USE SUMP_TRANS_MOD, ONLY: SUMP_TRANS USE SUMP_TRANS_PRELEG_MOD, ONLY: SUMP_TRANS_PRELEG USE SULEG_MOD, ONLY: SULEG USE PRE_SULEG_MOD, ONLY: PRE_SULEG USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE SHAREDMEM_MOD, ONLY: SHAREDMEM_CREATE USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE PREPSNM_MOD, ONLY: PREPSNM #ifdef ACCGPU USE OPENACC, ONLY: ACC_DEVICE_KIND, ACC_GET_DEVICE_TYPE, ACC_GET_NUM_DEVICES, & & ACC_SET_DEVICE_NUM, ACC_GET_DEVICE_NUM #endif !endif INTERFACE IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM) ,INTENT(IN) :: KSMAX,KDGL INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KDLON INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KLOEN(:) LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KTMAX INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT):: KRESOL REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PSTRET LOGICAL ,OPTIONAL,INTENT(IN):: LDGRIDONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFLT LOGICAL ,OPTIONAL,INTENT(IN):: LD_ALL_FFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDUSERPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDKEEPRPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDSPSETUPONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDPNMONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDLL LOGICAL ,OPTIONAL,INTENT(IN):: LDSHIFTLL CHARACTER(LEN=*),OPTIONAL,INTENT(IN):: CDIO_LEGPOL CHARACTER(LEN=*),OPTIONAL,INTENT(IN):: CDLEGPOLFNAME TYPE(C_PTR) ,OPTIONAL,INTENT(IN) :: KLEGPOLPTR INTEGER(C_SIZE_T) ,OPTIONAL,INTENT(IN) :: KLEGPOLPTR_LEN !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: JGL, JRES, IDEF_RESOL INTEGER(KIND=JPIM) :: JMLOC, KM, ILA, ILS, KDGLU INTEGER(KIND=JPIM) :: IMLOC0(1) LOGICAL :: LLP1, LLP2, LLSPSETUPONLY REAL(KIND=JPHOOK) :: ZHOOK_HANDLE #ifdef ACCGPU INTEGER(ACC_DEVICE_KIND) :: IDEVTYPE #endif INTEGER :: INUMDEVS, IDEV, MYGPU REAL(KIND=JPRBT), POINTER :: LOCAL_ARR(:,:) ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SETUP_TRANS',0,ZHOOK_HANDLE) IF(MSETUP0 == 0) THEN CALL ABORT_TRANS('SETUP_TRANS: SETUP_TRANS0 HAS TO BE CALLED BEFORE SETUP_TRANS') ENDIF LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SETUP_TRANS ===' IF(LLP1) THEN IF (JPRBT == JPRD) THEN WRITE(NOUT,'(A)') "GPU double precision version, with following compile-time options : " ELSE WRITE(NOUT,'(A)') "GPU single precision version, with following compile-time options : " ENDIF #ifdef ACCGPU WRITE(NOUT,'(A)') " - OpenACC-based offload" #else WRITE(NOUT,'(A)') " - OpenMP-based offload" #endif #ifdef USE_GPU_AWARE_MPI WRITE(NOUT,'(A)') " - GPU-aware MPI" #endif #ifdef USE_GRAPHS_FFT WRITE(NOUT,'(A)') " - graph-based FFT scheduling" #endif #ifdef USE_GRAPHS_GEMM WRITE(NOUT,'(A)') " - graph-based GEMM scheduling" #endif #ifdef USE_CUTLASS WRITE(NOUT,'(A)') " - Cutlass-based GEMM operations" #endif #ifdef USE_3XTF32 WRITE(NOUT,'(A)') " - tensor-core usage for 32b Cutlass operations" #endif WRITE(NOUT,'(A)') ENDIF ! Allocate resolution dependent structures IF(.NOT. ALLOCATED(DIM_RESOL)) THEN IDEF_RESOL = 1 ALLOCATE(DIM_RESOL(NMAX_RESOL)) ALLOCATE(FIELDS_RESOL(NMAX_RESOL)) ALLOCATE(FIELDS_GPU_RESOL(NMAX_RESOL)) ALLOCATE(GEOM_RESOL(NMAX_RESOL)) ALLOCATE(DISTR_RESOL(NMAX_RESOL)) ALLOCATE(FLT_RESOL(NMAX_RESOL)) ALLOCATE(CTL_RESOL(NMAX_RESOL)) GEOM_RESOL(:)%LAM=.FALSE. ALLOCATE(LENABLED(NMAX_RESOL)) LENABLED(:)=.FALSE. ELSE IDEF_RESOL = NMAX_RESOL+1 DO JRES=1,NMAX_RESOL IF(.NOT.LENABLED(JRES)) THEN IDEF_RESOL = JRES EXIT ENDIF ENDDO IF(IDEF_RESOL > NMAX_RESOL) THEN CALL ABORT_TRANS('SETUP_TRANS:IDEF_RESOL > NMAX_RESOL') ENDIF ENDIF IF (PRESENT(KRESOL)) THEN KRESOL=IDEF_RESOL ENDIF ! Point at structures due to be initialized CALL SET_RESOL(IDEF_RESOL,LDSETUP=.TRUE.) IF(LLP1) WRITE(NOUT,*) '=== DEFINING RESOLUTION ',NCUR_RESOL ! Defaults for optional arguments G%LREDUCED_GRID = .FALSE. G%RSTRET=1.0_JPRBT D%LGRIDONLY = .FALSE. D%LSPLIT = .FALSE. D%LCPNMONLY=.FALSE. S%LUSE_BELUSOV=.TRUE. ! use Belusov algorithm to compute RPNM array instead of per m S%LKEEPRPNM=.FALSE. ! Keep Legendre polonomials (RPNM) LLSPSETUPONLY = .FALSE. ! Only create distributed spectral setup S%LDLL = .FALSE. ! use mapping to/from second set of latitudes S%LSHIFTLL = .FALSE. ! shift output lat-lon by 0.5dx, 0.5dy C%LREAD_LEGPOL = .FALSE. C%LWRITE_LEGPOL = .FALSE. ! NON-OPTIONAL ARGUMENTS R%NSMAX = KSMAX R%NDGL = KDGL ! E'-defaults R%NNOEXTZL=0 R%NNOEXTZG=0 IF(PRESENT(LDSPSETUPONLY)) THEN LLSPSETUPONLY=LDSPSETUPONLY ! <<<<<<<<<<< EXTRA TO WORKAROUND NOT YET IMPLEMENTED FEATURE IF (LLSPSETUPONLY) THEN WRITE(NOUT,'(A)') "DEVELOPER WARNING: LDSPSETUPONLY IS NOT YET IMPLEMENTED CORRECTLY WITH GPU BACKEND. IGNORING IT FOR NOW" LLSPSETUPONLY = .FALSE. R%NDGL = NPROC ! Make even and positive IF (MOD(R%NDGL,2) /= 0) THEN R%NDGL = NPROC+1 ENDIF R%NDGL = MAX(2,R%NDGL) ENDIF ! >>>>>>>>>>>>> ENDIF ! IMPLICIT argument : G%LAM = .FALSE. IF(PRESENT(KDLON)) THEN R%NDLON = KDLON ELSE R%NDLON = 2*R%NDGL ENDIF IF(PRESENT(LDLL)) THEN S%LDLL=LDLL IF( LDLL ) THEN CALL ABORT_TRANS ('SETUP_TRANS: LDLL=.TRUE. is not yet supported with GPU backend') S%NDLON=R%NDLON ! account for pole + equator R%NDGL=R%NDGL+2 IF(PRESENT(LDSHIFTLL)) THEN S%LSHIFTLL = LDSHIFTLL ! geophysical (shifted) lat-lon without pole and equator IF(S%LSHIFTLL) R%NDGL=R%NDGL-2 ENDIF S%NDGL=R%NDGL ENDIF ENDIF IF (R%NDGL <= 0 .OR. MOD(R%NDGL,2) /= 0) THEN CALL ABORT_TRANS ('SETUP_TRANS: KDGL IS NOT A POSITIVE, EVEN NUMBER') ENDIF ! Optional arguments ALLOCATE(G%NLOEN(R%NDGL)) IF (LLP2) WRITE(NOUT,'("ARRAY NLOEN ALLOCATED",8I8)') SIZE(G%NLOEN ),SHAPE(G%NLOEN ) IF(PRESENT(KLOEN)) THEN IF( MINVAL(KLOEN(:)) <= 0 )THEN CALL ABORT_TRANS ('SETUP_TRANS: KLOEN INVALID (ONE or MORE POINTS <= 0)') ENDIF R%NDLON=MAXVAL(KLOEN(:)) DO JGL=1,R%NDGL IF(KLOEN(JGL) /= R%NDLON) THEN G%LREDUCED_GRID = .TRUE. EXIT ENDIF ENDDO ENDIF IF (G%LREDUCED_GRID) THEN G%NLOEN(:) = KLOEN(1:R%NDGL) ELSE G%NLOEN(:) = R%NDLON ENDIF IF(PRESENT(LDSPLIT)) THEN D%LSPLIT = LDSPLIT ENDIF IF(PRESENT(KTMAX)) THEN R%NTMAX = KTMAX ELSE R%NTMAX = R%NSMAX ENDIF IF(PRESENT(PWEIGHT)) THEN D%LWEIGHTED_DISTR = .TRUE. IF( D%LWEIGHTED_DISTR .AND. .NOT.D%LSPLIT )THEN CALL ABORT_TRANS('SETUP_TRANS: LWEIGHTED_DISTR=T AND LSPLIT=F NOT SUPPORTED') ENDIF IF(SIZE(PWEIGHT) /= SUM(G%NLOEN(:)) )THEN CALL ABORT_TRANS('SETUP_TRANS:SIZE(PWEIGHT) /= SUM(G%NLOEN(:))') ENDIF IF( MINVAL(PWEIGHT(:)) < 0.0_JPRBT )THEN CALL ABORT_TRANS('SETUP_TRANS: INVALID WEIGHTS') ENDIF ALLOCATE(D%RWEIGHT(SIZE(PWEIGHT))) D%RWEIGHT(:)=PWEIGHT(:) ELSE D%LWEIGHTED_DISTR = .FALSE. ENDIF IF(PRESENT(LDGRIDONLY)) THEN D%LGRIDONLY=LDGRIDONLY ! <<<<<<<<<<< EXTRA TO WORKAROUND NOT YET IMPLEMENTED FEATURE IF (D%LGRIDONLY) THEN R%NSMAX=1 R%NTMAX = R%NSMAX WRITE(NOUT,'(A,I0)') "DEVELOPER WARNING: LDGRIDONLY IS NOT YET IMPLEMENTED CORRECTLY WITH GPU& & BACKEND. IGNORE AND USE TRUNCATION: ", R%NSMAX D%LGRIDONLY = .FALSE. ENDIF ! >>>>>>>>>>>>> ENDIF IF(PRESENT(LDPNMONLY)) THEN D%LCPNMONLY=LDPNMONLY ENDIF IF(PRESENT(LDUSEFFTW)) THEN WRITE(NOUT,*) 'SETUP_TRANS: LDUSEFFTW option is not relevant for GPUs' ENDIF ! Setup distribution independent dimensions CALL SETUP_DIMS IF(PRESENT(LD_ALL_FFTW)) THEN WRITE(NOUT,*) 'SETUP_TRANS: LD_ALL_FFTW option is not relevant for GPUs' ENDIF S%LSOUTHPNM=.FALSE. IF(PRESENT(PSTRET)) THEN IF (ABS(PSTRET-1.0_JPRBT)>100._JPRBT*EPSILON(1._JPRBT)) THEN G%RSTRET=PSTRET S%LSOUTHPNM=.TRUE. R%NLEI3=2*R%NLEI3 ! double ENDIF ENDIF IF(PRESENT(CDIO_LEGPOL)) THEN IF(NPROC > 1) CALL ABORT_TRANS('SETUP_TRANS:CDIO_LEGPOL OPTIONS ONLY FOR NPROC=1 ') IF(TRIM(CDIO_LEGPOL) == 'readf' .OR. TRIM(CDIO_LEGPOL) == 'READF' ) THEN IF(.NOT.PRESENT(CDLEGPOLFNAME)) CALL ABORT_TRANS('SETUP_TRANS: CDLEGPOLFNAME ARGUMENT MISSING') C%LREAD_LEGPOL = .TRUE. C%CLEGPOLFNAME = TRIM(CDLEGPOLFNAME) C%CIO_TYPE='file' ELSEIF(TRIM(CDIO_LEGPOL) == 'writef' .OR. TRIM(CDIO_LEGPOL) == 'WRITEF') THEN IF(.NOT.PRESENT(CDLEGPOLFNAME)) CALL ABORT_TRANS('SETUP_TRANS: CDLEGPOLFNAME ARGUMENT MISSING') C%LWRITE_LEGPOL = .TRUE. C%CLEGPOLFNAME = TRIM(CDLEGPOLFNAME) C%CIO_TYPE='file' ELSEIF(TRIM(CDIO_LEGPOL) == 'membuf' .OR. TRIM(CDIO_LEGPOL) == 'MEMBUF') THEN IF(.NOT.PRESENT(KLEGPOLPTR)) CALL ABORT_TRANS('SETUP_TRANS: KLEGPOLPTR ARGUMENT MISSING') IF(.NOT.C_ASSOCIATED(KLEGPOLPTR)) CALL ABORT_TRANS('SETUP_TRANS: KLEGPOLPTR NULL POINTER') IF(.NOT.PRESENT(KLEGPOLPTR_LEN)) CALL ABORT_TRANS('SETUP_TRANS: KLEGPOLPTR_LEN ARGUMENT MISSING') C%LREAD_LEGPOL = .TRUE. C%CIO_TYPE='mbuf' CALL SHAREDMEM_CREATE( C%STORAGE,KLEGPOLPTR,KLEGPOLPTR_LEN) ELSE WRITE(NERR,*) 'CDIO_LEGPOL ', TRIM(CDIO_LEGPOL) CALL ABORT_TRANS('SETUP_TRANS:CDIO_LEGPOL UNKNOWN METHOD ') ENDIF ENDIF IF(PRESENT(LDUSEFLT)) THEN IF (LDUSEFLT) THEN CALL ABORT_TRANS('SETUP_TRANS: LDUSEFLT option is not supported for GPU') ENDIF ENDIF IF(PRESENT(LDUSERPNM)) THEN S%LUSE_BELUSOV=LDUSERPNM ENDIF IF(PRESENT(LDKEEPRPNM)) THEN S%LKEEPRPNM=LDKEEPRPNM ENDIF ! Setup resolution dependent structures ! ------------------------------------- ! First part of setup of distributed environment CALL SUMP_TRANS_PRELEG IF( .NOT.LLSPSETUPONLY ) THEN ! Compute Legendre polonomial and Gaussian Latitudes and Weights CALL SULEG ! Second part of setup of distributed environment CALL SUMP_TRANS CALL GSTATS(1802,0) CALL GSTATS(1802,1) ELSE CALL PRE_SULEG ENDIF ! Signal the current resolution is active LENABLED(IDEF_RESOL)=.TRUE. NDEF_RESOL = COUNT(LENABLED) IF (LHOOK) CALL DR_HOOK('SETUP_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ IF( .NOT.D%LGRIDONLY ) THEN #ifdef ACCGPU IDEVTYPE = ACC_GET_DEVICE_TYPE() INUMDEVS = ACC_GET_NUM_DEVICES(IDEVTYPE) MYGPU = MOD(MYPROC-1, INUMDEVS) CALL ACC_SET_DEVICE_NUM(MYGPU, IDEVTYPE) #endif WRITE(NOUT,*) 'R%NTMAX=',R%NTMAX WRITE(NOUT,*) 'R%NSMAX=',R%NSMAX ! Initialize A arrays ALLOCATE(FG%ZAA(D%OFFSETS_GEMM_MATRIX(D%NUMP+1))) ALLOCATE(FG%ZAS(D%OFFSETS_GEMM_MATRIX(D%NUMP+1))) FG%ZAA(:) = 0._JPRBT FG%ZAS(:) = 0._JPRBT DO JMLOC=1,D%NUMP KM = D%MYMS(JMLOC) KDGLU = G%NDGLU(KM) ILA = (R%NSMAX-KM+2)/2 ILS = (R%NSMAX-KM+3)/2 IF (KM /= 0) THEN CALL C_F_POINTER(C_LOC(FG%ZAA(1+D%OFFSETS_GEMM_MATRIX(JMLOC))), LOCAL_ARR, & & (/D%LEGENDRE_MATRIX_STRIDES(JMLOC),ILA/)) LOCAL_ARR(1:KDGLU,1:ILA) = S%FA(JMLOC)%RPNMA(1:KDGLU,1:ILA) CALL C_F_POINTER(C_LOC(FG%ZAS(1+D%OFFSETS_GEMM_MATRIX(JMLOC))), LOCAL_ARR, & & (/D%LEGENDRE_MATRIX_STRIDES(JMLOC),ILS/)) LOCAL_ARR(1:KDGLU,1:ILS) = S%FA(JMLOC)%RPNMS(1:KDGLU,1:ILS) ELSE ALLOCATE(FG%ZAA0(ALIGN(KDGLU,8),ILA)) ALLOCATE(FG%ZAS0(ALIGN(KDGLU,8),ILS)) FG%ZAA0(:,:) = 0 FG%ZAS0(:,:) = 0 FG%ZAA0(1:KDGLU,1:ILA)=S%FA(JMLOC)%RPNMA(1:KDGLU,1:ILA) FG%ZAS0(1:KDGLU,1:ILS)=S%FA(JMLOC)%RPNMS(1:KDGLU,1:ILS) ENDIF ENDDO ALLOCATE(FG%ZEPSNM(D%NUMP,0:R%NTMAX+2)) FG%ZEPSNM = 0._JPRBT CALL PREPSNM WRITE(NOUT,*)'setup_trans: sizes1 NUMP=',D%NUMP #ifdef ACCGPU WRITE(NOUT,*) 'Using OpenACC' #endif #ifdef OMPGPU WRITE(NOUT,*) 'Using OpenMP offloading' #endif ! Print sizes of Legendre polynomial work arrays (these numbers can be BIG so we need to use a ! nice and wide integer type like JPIB) WRITE(NOUT,'(A10,":",I13,"B")') 'FG%ZAS', C_SIZEOF(FG%ZAS(1))*SIZE(FG%ZAS,KIND=JPIB) WRITE(NOUT,'(A10,":",I13,"B")') 'FG%ZAA', C_SIZEOF(FG%ZAA(1))*SIZE(FG%ZAA,KIND=JPIB) WRITE(NOUT,'(A10,":",I13,"B")') 'FG%ZAS0', C_SIZEOF(FG%ZAS0(1,1))*SIZE(FG%ZAS0,KIND=JPIB) WRITE(NOUT,'(A10,":",I13,"B")') 'FG%ZAA0', C_SIZEOF(FG%ZAA0(1,1))*SIZE(FG%ZAA0,KIND=JPIB) WRITE(NOUT,'(A10,":",I13,"B")') 'FG%ZEPSNM', C_SIZEOF(FG%ZEPSNM(1,1))*SIZE(FG%ZEPSNM,KIND=JPIB) IF (ANY(D%MYMS == 0)) THEN #ifdef ACCGPU !$ACC ENTER DATA COPYIN(FG%ZAA0,FG%ZAS0) ASYNC(1) #endif #ifdef OMPGPU !$OMP TARGET ENTER DATA MAP(TO:FG%ZAA0,FG%ZAS0) #endif ENDIF #ifdef ACCGPU #ifdef _CRAYFTN !$ACC ENTER DATA COPYIN(R,R%NSMAX,R%NTMAX,R%NDGL,R%NDGNH) ASYNC(1) #else !$ACC ENTER DATA COPYIN(R) ASYNC(1) #endif !$ACC ENTER DATA COPYIN(F,F%RLAPIN,F%RACTHE,F%RW) ASYNC(1) !$ACC ENTER DATA COPYIN(FG,FG%ZAA,FG%ZAS,FG%ZEPSNM) ASYNC(1) #ifdef _CRAYFTN !$ACC ENTER DATA COPYIN(D,D%NUMP,D%MYMS,D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,D%NPROCM,D%NPROCL)& !$ACC& COPYIN(D%NPTRLS,D%MSTABF,D%NASM0,D%OFFSETS_GEMM1,D%OFFSETS_GEMM2,D%NDGL_FS) ASYNC(1) #else !$ACC ENTER DATA COPYIN(D,D%MYMS,D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,D%NPROCM,D%NPROCL)& !$ACC& COPYIN(D%NPTRLS,D%MSTABF,D%NASM0,D%OFFSETS_GEMM1,D%OFFSETS_GEMM2) ASYNC(1) #endif !$ACC ENTER DATA COPYIN(G,G%NDGLU,G%NMEN,G%NLOEN) ASYNC(1) !$ACC WAIT(1) #endif #ifdef OMPGPU !$OMP TARGET ENTER DATA MAP(TO:R,R%NSMAX,R%NTMAX,R%NDGL,R%NDGNH) !$OMP TARGET ENTER DATA MAP(TO:F,F%RLAPIN,F%RACTHE,F%RW) !$OMP TARGET ENTER DATA MAP(TO:FG,FG%ZAA,FG%ZAS,FG%ZEPSNM) !$OMP TARGET ENTER DATA MAP(TO:D,D%NUMP,D%MYMS,D%NPNTGTB0,D%NPNTGTB1,D%NSTAGT0B,D%NSTAGT1B,D%NSTAGTF,& !$OMP& D%NPROCM,D%NPROCL,D%NPTRLS,D%MSTABF,D%NASM0,D%OFFSETS_GEMM1,& !$OMP& D%OFFSETS_GEMM2,D%NDGL_FS) !$OMP TARGET ENTER DATA MAP(TO:G,G%NDGLU,G%NMEN,G%NLOEN) #endif WRITE(NOUT,*) '===GPU arrays successfully allocated' ! TODO: This might be good idea - those polynomials are not needed !DO JMLOC=1,D%NUMP ! DEALLOCATE(S%FA(JMLOC)%RPNMA) ! DEALLOCATE(S%FA(JMLOC)%RPNMS) !ENDDO ENDIF ! D%LGRIDONLY !endif INTERFACE END SUBROUTINE SETUP_TRANS ectrans-1.8.0/src/trans/gpu/external/vordiv_to_uv.F900000775000175000017500000001177615174631767022743 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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 VORDIV_TO_UV(PSPVOR,PSPDIV,PSPU,PSPV,KSMAX,KVSETUV) !**** *VORDIV_TO_UV* - Convert spectral vorticity and divergence to spectral U (u*cos(theta)) and V (v*cos(theta). ! Purpose. ! -------- ! Interface routine for Convert spectral vorticity and divergence to spectral U and V !** Interface. ! ---------- ! CALL VORDIV_TO_UV(...) ! Explicit arguments : ! -------------------- ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPU(:,:) - spectral U (u*cos(theta) (output) ! PSPV(:,:) - spectral V (v*cos(theta) (output) ! KSMAX - spectral resolution (input) ! KVSETUV(:) - Optionally 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. ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- VD2UV_CTL - control vordiv to uv ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 15-06-15 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR, NOUT,MSETUP0 USE TPM_DISTR, ONLY: D, NPRTRV, MYSETV USE SET_RESOL_MOD, ONLY: SET_RESOL USE VD2UV_CTL_MOD, ONLY: VD2UV_CTL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB), INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB), INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PSPU(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PSPV(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) !ifndef INTERFACE ! Local varaibles INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IRESOL,IDGL LOGICAL :: LTMP_SETUP0 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE #include "setup_trans0.h" #include "setup_trans.h" #include "trans_release.h" #include "trans_end.h" ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('VORDIV_TO_UV',0,ZHOOK_HANDLE) CALL ABORT_TRANS('VORDIV_TO_UV: Code path not (yet) supported in GPU version') !CALL GSTATS(XXXX,0) IF(MSETUP0 == 0) THEN CALL SETUP_TRANS0() LTMP_SETUP0 = .TRUE. ELSE LTMP_SETUP0 = .FALSE. ENDIF IDGL = 2 ! It doesn't matter as long as it's a positive even number CALL SETUP_TRANS(KSMAX,IDGL,LDSPSETUPONLY=.TRUE.,KRESOL=IRESOL) CALL SET_RESOL(IRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'VORDIV_TO_UV:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('VORDIV_TO_UV:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSETUV(J) == MYSETV) THEN IF_UV = IF_UV+1 ENDIF ENDDO ELSE IF_UV = UBOUND(PSPVOR,1) IF_UV_G = IF_UV ENDIF ! Consistency checks IF (IF_UV > 0) THEN IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPVOR TOO SHORT') ENDIF IF(UBOUND(PSPDIV,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPDIV TOO SHORT') ENDIF IF(UBOUND(PSPU,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPU,1) < IF_UV ',UBOUND(PSPU,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPU TOO SHORT') ENDIF IF(UBOUND(PSPV,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPV,1) < IF_UV ',UBOUND(PSPV,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPV TOO SHORT') ENDIF 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('VORDIV_TO_UV: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF !CALL GSTATS(XXXX,1) ! ------------------------------------------------------------------ ! Perform transform CALL VD2UV_CTL(IF_UV,PSPVOR,PSPDIV,PSPU,PSPV) CALL TRANS_RELEASE(IRESOL) IF (LTMP_SETUP0) THEN CALL TRANS_END() ENDIF IF (LHOOK) CALL DR_HOOK('VORDIV_TO_UV',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE VORDIV_TO_UV ectrans-1.8.0/src/trans/gpu/external/dist_spec.F900000775000175000017500000001332115174631767022157 0ustar alastairalastair! (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 DIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& & LDIM1_IS_FLD,KSMAX,KSORT) !**** *DIST_SPEC* - Distribute global spectral array among processors ! Purpose. ! -------- ! Interface routine for distributing spectral array !** Interface. ! ---------- ! CALL DIST__SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PSPEC(:,:) - Local spectral array ! KSORT (:) - Re-order fields on output ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! P.Marguinaud : 10-10-14 Add KSORT ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D, NPRTRV, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE DIST_SPEC_CONTROL_MOD, ONLY: DIST_SPEC_CONTROL USE SUWAVEDI_MOD, ONLY: SUWAVEDI 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(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFDISTG) INTEGER(KIND=JPIM) :: IFSEND,IFRECV,J,IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIST_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) LLDIM1_IS_FLD = .TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD = 1 ICOEFF = 2 ELSE IFLD = 2 ICOEFF = 1 ENDIF IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_SPEC: KFROM TOO SHORT!') ENDIF ISMAX = R%NSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX ALLOCATE(IDIM0G(0:ISMAX)) IF(ISMAX /= R%NSMAX) THEN CALL SUWAVEDI(ISMAX,ISMAX,NPRTRW,MYSETW,KPOSSP=IPOSSP,KSPEC2=ISPEC2,& & KDIM0G=IDIM0G) ISPEC2_G = (ISMAX+1)*(ISMAX+2) ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ENDIF IFSEND = 0 IFRECV = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'DIST_SPEC:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('DIST_SPEC:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('DIST_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFSEND) THEN WRITE(NERR,*) 'DIST_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFSEND CALL ABORT_TRANS('DIST_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'DIST_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('DIST_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFDISTG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'DIST_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('DIST_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFRECV = IFRECV+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFDISTG) ELSE IFRECV = KFDISTG IVSET(:) = MYSETV ENDIF IF(IFRECV > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('DIST_SPEC: FIELDS TO RECEIVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFRECV) THEN CALL ABORT_TRANS('DIST_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('DIST_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (.NOT. PRESENT (PSPEC)) THEN CALL ABORT_TRANS('DIST_SPEC: KSORT REQUIRES PSPEC') ENDIF IF (UBOUND (KSORT, 1) /= UBOUND (PSPEC, IFLD)) THEN CALL ABORT_TRANS('DIST_SPEC: DIMENSION MISMATCH KSORT, PSPEC') ENDIF ENDIF CALL DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,IVSET,PSPEC,LLDIM1_IS_FLD,& & ISMAX,ISPEC2,ISPEC2_G,IPOSSP,IDIM0G,KSORT) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('DIST_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE DIST_SPEC ectrans-1.8.0/src/trans/gpu/external/dist_grid.F900000775000175000017500000001034415174631767022154 0ustar alastairalastair! (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 DIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) !**** *DIST_GRID* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:) - Local spectral array ! KSORT (:) - Re-order fields on output ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! P.Marguinaud : 10-10-14 Add KSORT ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR, NOUT USE TPM_DISTR, ONLY: D, MYPROC, NPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE DIST_GRID_CTL_MOD, ONLY: DIST_GRID_CTL 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(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIST_GRID',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_GRID: KFROM TOO SHORT!') ENDIF IFSEND = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'DIST_GRID:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('DIST_GRID:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'DIST_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('DIST_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFDISTG) THEN WRITE(NOUT,*)'DIST_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFDISTG CALL ABORT_TRANS('DIST_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'DIST_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('DIST_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('DIST_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('DIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFSEND) THEN CALL ABORT_TRANS('DIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (UBOUND (KSORT, 1) /= UBOUND (PGP, 2)) THEN CALL ABORT_TRANS('DIST_GRID: DIMENSION MISMATCH KSORT, PGP') ENDIF ENDIF CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP,KSORT) IF (LHOOK) CALL DR_HOOK('DIST_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID ectrans-1.8.0/src/trans/gpu/external/gath_grid_32.F900000775000175000017500000000774215174631767022450 0ustar alastairalastair! (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 GATH_GRID_32(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *GATH_GRID_32* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL GATH_GRID_32(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_32_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB, JPRM !ifndef INTERFACE USE TPM_GEN, ONLY: NERR,NOUT USE TPM_DISTR, ONLY: D, NPROC, MYPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE GATH_GRID_32_CTL_MOD, ONLY: GATH_GRID_32_CTL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRM) , INTENT(IN) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFRECV,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GATH_GRID_32',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_GRID_32: KTO TOO SHORT!') ENDIF IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_GRID_32:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_GRID_32:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'GATH_GRID_32:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('GATH_GRID_32:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFGATHG) THEN WRITE(NOUT,*)'GATH_GRID_32:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFGATHG CALL ABORT_TRANS('GATH_GRID_32:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'GATH_GRID_32:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('GATH_GRID_32:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('GATH_GRID_32:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('GATH_GRID_32:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFRECV) THEN CALL ABORT_TRANS('GATH_GRID_32:SECOND DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL GATH_GRID_32_CTL(PGPG,KFGATHG,IPROMA,KTO,PGP) IF (LHOOK) CALL DR_HOOK('GATH_GRID_32',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID_32 ectrans-1.8.0/src/trans/gpu/external/inv_transad.F900000775000175000017500000005444215174631767022523 0ustar alastairalastair! (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 resolution (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, LSYNC_TRANS USE TPM_TRANS, ONLY: LDIVGP, LSCDERS, LUVDER, LVORGP, LATLON, NF_SC2, NF_SC3A, NF_SC3B, & & NGPBLKS, NPROMA USE TPM_FLT, ONLY: S USE TPM_GEOMETRY, ONLY: G USE TPM_DISTR, ONLY: D, NPRTRV, MYSETV, MYPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE INV_TRANS_CTLAD_MOD, ONLY: INV_TRANS_CTLAD USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE MPL_MODULE, ONLY: MPL_BARRIER USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX !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) IF (LSYNC_TRANS) THEN CALL MPL_BARRIER(CDSTRING='') ENDIF CALL GSTATS(420,0) CALL GSTATS(1807,0) ! ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults LVORGP = .FALSE. LDIVGP = .FALSE. LUVDER = .FALSE. LATLON =.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 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 OR TOO LONG') 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 OR TOO LONG') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('INV_TRANSAD : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('INV_TRANSAD : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('INV_TRANSAD : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF IF(UBOUND(PSPSCALAR,1) /= IF_SCALARS) THEN WRITE(NERR,*)'INV_TRANSAD : UBOUND(PSPSCALAR,1) /= IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('INV_TRANSAD : PSPSCALAR TOO SHORT OR TOO LONG') 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/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'INV_TRANSAD:SEC. DIM. OF PGP TOO SMALL/LARGE ',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/LARGE ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP TOO SMALL/LARGE ') 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/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL/LARGE ') 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/LARGE ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL/LARGE ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANSAD:FOURTH DIM. OF PGPUV TOO SMALL/LARGE ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:FOURTH DIMENSION OF PGPUV TOO SMALL/LARGE ') 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/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP2 TOO SMALL/LARGE ') 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/LARGE ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL/LARGE ') 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/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL/LARGE ') 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/LARGE ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL/LARGE ') 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/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL/LARGE ') 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(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL/LARGE ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANSAD:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1807,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 (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(420,1) IF (LHOOK) CALL DR_HOOK('INV_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE INV_TRANSAD ectrans-1.8.0/src/trans/gpu/external/gath_grid.F900000775000175000017500000000761115174631767022137 0ustar alastairalastair! (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 GATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *GATH_GRID* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL GATH_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR, NOUT USE TPM_DISTR, ONLY: D, MYPROC, NPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE GATH_GRID_CTL_MOD, ONLY: GATH_GRID_CTL 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) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(IN) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFRECV,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GATH_GRID',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_GRID: KTO TOO SHORT!') ENDIF IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_GRID:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_GRID:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'GATH_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFGATHG) THEN WRITE(NOUT,*)'GATH_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFGATHG CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'GATH_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('GATH_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('GATH_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFRECV) THEN CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL GATH_GRID_CTL(PGPG,KFGATHG,IPROMA,KTO,PGP) IF (LHOOK) CALL DR_HOOK('GATH_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID ectrans-1.8.0/src/trans/gpu/external/inv_trans.F900000775000175000017500000005523615174631767022220 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & FSPGL_PROC,& & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,LDLATLON,KPROMA,KVSETUV,KVSETSC,KRESOL,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANS* - Inverse spectral transform. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform !** Interface. ! ---------- ! CALL INV_TRANS(...) ! Explicit arguments : All arguments 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. ! LDLATLON - indicating if regular lat-lon output requested ! 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 resolution (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 ! ---------- LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields ! and derivatives (IF_SCALARS_G) ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: NERR, NOUT, NPROMATR, LSYNC_TRANS USE TPM_TRANS, ONLY: LDIVGP, LSCDERS, LUVDER, LVORGP, LATLON, NF_SC2, NF_SC3A, NF_SC3B, & & NGPBLKS, NPROMA USE TPM_FLT, ONLY: S USE TPM_GEOMETRY, ONLY: G USE TPM_DISTR, ONLY: D, NPRTRV, MYSETV, MYPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE INV_TRANS_CTL_MOD, ONLY: INV_TRANS_CTL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE MPL_MODULE, ONLY: MPL_BARRIER USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TPM_STATS, ONLY: GSTATS => GSTATS_NVTX !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDSCDERS LOGICAL ,OPTIONAL, INTENT(IN) :: LDVORGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDDIVGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDUVDER LOGICAL ,OPTIONAL, INTENT(IN) :: LDLATLON 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(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: 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 INTEGER(KIND=JPIM) :: JMLOC INTEGER(KIND=JPIM) :: UNIT_NO,IDEVTYPE,NUMDEVS,MYGPU,MYNUM ! ------------------------------------------------------------------ UNIT_NO=300+MYPROC CALL FLUSH(UNIT_NO) IF (LHOOK) CALL DR_HOOK('INV_TRANS',0,ZHOOK_HANDLE) IF (LSYNC_TRANS) THEN CALL MPL_BARRIER(CDSTRING='') ENDIF CALL GSTATS(420,0) CALL GSTATS(1807,0) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults LVORGP = .FALSE. LDIVGP = .FALSE. LUVDER = .FALSE. LATLON =.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_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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(.NOT. PRESENT(PSPSCALAR) ) THEN CALL ABORT_TRANS('INV_TRANS : KVSETSC PRESENT BUT PSPSCALAR MISSING') ENDIF IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN WRITE(NERR,*) 'INV_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_TRANS: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_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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 + IF_SC2_G NF_SC2 = UBOUND(PSPSC2,1) ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS& &('INV_TRANS: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_TRANS: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_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_G > 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 IF(PRESENT(LDLATLON)) THEN LATLON = LDLATLON ENDIF ! Compute derived variables 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_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) /= IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPVOR,1) /= IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('INV_TRANS : PSPVOR TOO SHORT OR TOO LONG') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPDIV,1) /= IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('INV_TRANS : PSPDIV TOO SHORT OR TOO LONG') 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 OR TOO LONG') 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IF(PRESENT(PGPUV)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGPUV CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3A)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3A CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3B)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3B CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP2)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP TOO SMALL/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP TOO SMALL/LARGE ',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_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP TOO SMALL/LARGE ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP TOO SMALL/LARGE ') ENDIF ELSE IF(NPROMATR > 0 .AND. 2*IF_UV_G+IF_SCALARS_G > NPROMATR) THEN CALL ABORT_TRANS('INV_TRANS:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('INV_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGPUV TOO SMALL/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) < IF_UV_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < IF_UV_PAR) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL/LARGE ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL/LARGE ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGPUV TOO SMALL/LARGE ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL/LARGE ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP2 TOO SMALL/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP2 TOO SMALL/LARGE ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL/LARGE ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3A TOO SMALL/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3A TOO SMALL/LARGE ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL/LARGE ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3B TOO SMALL/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL/LARGE ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP3B TOO SMALL/LARGE ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL/LARGE ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1807,1) ! ------------------------------------------------------------------ ! Perform transform CALL INV_TRANS_CTL(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,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LSYNC_TRANS) THEN CALL GSTATS(440,0) CALL MPL_BARRIER(CDSTRING='') CALL GSTATS(440,1) ENDIF CALL GSTATS(420,1) IF (LHOOK) CALL DR_HOOK('INV_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE INV_TRANS ectrans-1.8.0/src/trans/gpu/external/gpnorm_trans.F900000775000175000017500000003245315174631767022722 0ustar alastairalastair! (C) Copyright 2008- ECMWF. ! (C) Copyright 2008- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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 GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !**** *GPNORM_TRANS* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL GPNORM_TRANS(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! Modifications. ! -------------- ! Original : 19th Sept 2008 ! R. El Khatib 07-08-2009 Optimisation directive for NEC ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB, JPRD USE PARKIND_ECTRANS, ONLY: JPRBT !ifndef INTERFACE USE TPM_GEN, ONLY: NOUT USE TPM_DIM, ONLY: R USE TPM_TRANS, ONLY: LGPNORM, NGPBLKS, NPROMA USE TPM_DISTR, ONLY: D, NPRCIDS, NPRTRV, NPRTRW, MYSETV, MYSETW, NPROC, MYPROC USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS, ONLY: F USE SET_RESOL_MOD, ONLY: SET_RESOL USE SET2PE_MOD, ONLY: SET2PE USE MPL_MODULE, ONLY: MPL_RECV, MPL_SEND, JP_BLOCKING_STANDARD USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK USE TRGTOL_MOD, ONLY: TRGTOL_HANDLE, PREPARE_TRGTOL, TRGTOL USE TPM_TRANS, ONLY: GROWING_ALLOCATION USE BUFFERED_ALLOCATOR_MOD, ONLY: BUFFERED_ALLOCATOR, MAKE_BUFFERED_ALLOCATOR, INSTANTIATE_ALLOCATOR !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL ,INTENT(IN) :: LDAVE_ONLY INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IUBOUND(4) INTEGER(KIND=JPIM) :: IVSET(KFIELDS) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETG(:,:) !GPU REAL(KIND=JPRBT) :: V REAL(KIND=JPRBT), POINTER :: PREEL_REAL(:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGL(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGL(:,:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMINGPN(:) REAL(KIND=JPRBT),ALLOCATABLE :: ZMAXGPN(:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVEG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZMING(:) REAL(KIND=JPRB),ALLOCATABLE :: ZMAXG(:) REAL(KIND=JPRD),ALLOCATABLE :: ZSND(:) REAL(KIND=JPRD),ALLOCATABLE :: ZRCV(:) INTEGER(KIND=JPIM) :: J,JGL,IGL,JL,JF,IF_GP,IF_SCALARS_G,IF_FS,JSETV,JSETW,IWLATS,JMAX INTEGER(KIND=JPIM) :: IPROC,ITAG,ILEN,ILENR,IBEG,IEND,IND TYPE(BUFFERED_ALLOCATOR) :: ALLOCATOR TYPE(TRGTOL_HANDLE) :: HTRGTOL !INTEGER(KIND=JPIM) :: iunit ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults NPROMA = KPROMA NGPBLKS = (D%NGPTOT-1)/NPROMA+1 ! Consistency checks IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'GPNORM_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('GPNORM_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFIELDS) THEN WRITE(NOUT,*)'GPNORM_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFIELDS CALL ABORT_TRANS('GPNORM_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'GPNORM_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('GPNORM_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ASSOCIATE(F_RW=>F%RW, D_NSTAGTF=>D%NSTAGTF, D_NPTRLS=>D%NPTRLS, G_NLOEN=>G%NLOEN) IF_GP=KFIELDS IF_SCALARS_G=KFIELDS IF_FS=0 DO J=1,KFIELDS IVSET(J)=MOD(J-1,NPRTRV)+1 IF(IVSET(J)==MYSETV)THEN IF_FS=IF_FS+1 ENDIF ENDDO ALLOCATE(ZAVE(IF_FS,R%NDGL)) ALLOCATE(ZMINGL(IF_FS,R%NDGL)) ALLOCATE(ZMAXGL(IF_FS,R%NDGL)) ALLOCATE(ZMINGPN(IF_FS)) ALLOCATE(ZMAXGPN(IF_FS)) ZAVE = 0._JPRBT ZMINGL = 0._JPRBT ZMAXGL = 0._JPRBT ZMINGPN = 0._JPRBT ZMAXGPN = 0._JPRBT #ifdef OMPGPU !$OMP TARGET DATA MAP(TOFROM:ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) #endif #ifdef ACCGPU !$ACC DATA COPY(ZAVE,ZMINGL,ZMAXGL,ZMINGPN,ZMAXGPN) #endif ALLOCATE(IVSETS(NPRTRV)) IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 ENDDO ALLOCATE(IVSETG(NPRTRV,MAXVAL(IVSETS(:)))) IVSETG(:,:)=0 IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 IVSETG(IVSET(J),IVSETS(IVSET(J)))=J ENDDO !iunit=300+myproc !DO JF=1,IF_GP ! write(iunit,*) 'PGP field=',JF,PGP(1,JF,1),PGP(NPROMA,JF,1),PGP(1,JF,NGPBLKS) !ENDDO ALLOCATOR = MAKE_BUFFERED_ALLOCATOR() HTRGTOL = PREPARE_TRGTOL(ALLOCATOR,IF_GP,IF_FS) CALL INSTANTIATE_ALLOCATOR(ALLOCATOR, GROWING_ALLOCATION) LGPNORM=.TRUE. CALL TRGTOL(ALLOCATOR,HTRGTOL,PREEL_REAL,IF_FS,IF_GP,0,IF_SCALARS_G,& & KVSETSC=IVSET,PGP=PGP) LGPNORM=.FALSE. IBEG=1 IEND=D%NDGL_FS CALL GSTATS(1429,0) IF( IF_FS > 0 )THEN #ifdef OMPGPU !$OMP TARGET DATA MAP(PRESENT,ALLOC:F,F_RW,D,D_NSTAGTF,D_NPTRLS,G_NLOEN) #endif #ifdef ACCGPU !$ACC DATA PRESENT(F,F_RW,D,D_NSTAGTF,D_NPTRLS,G_NLOEN) #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO #endif #ifdef ACCGPU !$ACC KERNELS #endif DO JF=1,IF_FS ZMINGL(JF,IBEG:IEND)=HUGE(1_JPRBT) ZMAXGL(JF,IBEG:IEND)=-HUGE(1_JPRBT) ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif ! FIRST DO SUMS IN EACH FULL LATITUDE #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO & !$OMP& PRIVATE(IGL,V) #endif #ifdef ACCGPU !$ACC KERNELS #endif DO JGL=1,D%NDGL_FS IGL = D_NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=0.0_JPRB #ifdef ACCGPU !$ACC loop #endif DO JL=1,G_NLOEN(IGL) V = PREEL_REAL(IF_FS*D%NSTAGTF(JGL)+(JF-1)*(D%NSTAGTF(JGL+1)-D%NSTAGTF(JGL))+JL) ZAVE(JF,JGL)=ZAVE(JF,JGL)+V ZMINGL(JF,JGL)=MIN(ZMINGL(JF,JGL),V) ZMAXGL(JF,JGL)=MAX(ZMAXGL(JF,JGL),V) ENDDO ENDDO ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO #endif #ifdef ACCGPU !$ACC KERNELS #endif DO JF=1,IF_FS ZMINGPN(JF)=MINVAL(ZMINGL(JF,IBEG:IEND)) ZMAXGPN(JF)=MAXVAL(ZMAXGL(JF,IBEG:IEND)) ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif #ifdef OMPGPU !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO & !$OMP& PRIVATE(IGL) #endif #ifdef ACCGPU !$ACC KERNELS #endif DO JGL=IBEG,IEND IGL = D_NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=ZAVE(JF,JGL)*F_RW(IGL)/G_NLOEN(IGL) !write(iunit,*) 'aver inside ',JF,IF_FS,IGL,ZAVE(JF,JGL), F_RW(IGL), G_NLOEN(IGL),ZMINGPN(JF),ZMAXGPN(JF) ENDDO ENDDO #ifdef ACCGPU !$ACC END KERNELS #endif #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif ENDIF #ifdef OMPGPU !$OMP END TARGET DATA #endif #ifdef ACCGPU !$ACC END DATA #endif CALL GSTATS(1429,1) END ASSOCIATE ! from here rest on CPU ! IT IS IMPORTANT THAT SUMS ARE NOW DONE IN LATITUDE ORDER ALLOCATE(ZAVEG(R%NDGL,KFIELDS)) ALLOCATE(ZMING(KFIELDS)) ALLOCATE(ZMAXG(KFIELDS)) ZAVEG(:,:)=0.0_JPRD DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 ZAVEG(IGL,IVSETG(MYSETV,JF))=ZAVEG(IGL,IVSETG(MYSETV,JF))+ZAVE(JF,JGL) ENDDO ENDDO IF(LDAVE_ONLY)THEN ZMING(:)=PMIN(:) ZMAXG(:)=PMAX(:) ELSE DO JF=1,IF_FS ZMING(IVSETG(MYSETV,JF))=ZMINGPN(JF) ZMAXG(IVSETG(MYSETV,JF))=ZMAXGPN(JF) ENDDO ENDIF ! RECEIVE ABOVE FROM OTHER NPRTRV SETS FOR SAME LATS BUT DIFFERENT FIELDS ITAG=123 CALL GSTATS(815,0) IF( MYSETV==1 )THEN DO JSETV=2,NPRTRV IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*IVSETS(JSETV)+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*IVSETS(JSETV) ENDIF IF(ILEN > 0)THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,MYSETW,JSETV) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS:V') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS:ILENR /= ILEN') ENDIF IND=0 DO JF=1,IVSETS(JSETV) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,IVSETG(JSETV,JF))=ZRCV(IND) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZMING(IVSETG(JSETV,JF))=ZRCV(IND) IND=IND+1 ZMAXG(IVSETG(JSETV,JF))=ZRCV(IND) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),JPRB)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),JPRB)) ENDDO ENDIF DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*IVSETS(MYSETV)+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*IVSETS(MYSETV) ENDIF IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,MYSETW,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,IVSETG(MYSETV,JF)) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZSND(IND)=ZMING(IVSETG(MYSETV,JF)) IND=IND+1 ZSND(IND)=ZMAXG(IVSETG(MYSETV,JF)) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZSND(IND)=PMIN(JF) IND=IND+1 ZSND(IND)=PMAX(JF) ENDDO ENDIF CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS:V') DEALLOCATE(ZSND) ENDIF ENDIF ! FINALLY RECEIVE CONTRIBUTIONS FROM OTHER NPRTRW SETS IF( MYSETV == 1 )THEN IF( MYSETW == 1 )THEN DO JSETW=2,NPRTRW IWLATS=D%NULTPP(JSETW) IBEG=1 IEND=IWLATS IF(LDAVE_ONLY)THEN ILEN=IWLATS*KFIELDS+2*KFIELDS ELSE ILEN=(IWLATS+2)*KFIELDS ENDIF IF(ILEN > 0 )THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,JSETW,1) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS:W') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS:ILENR /= ILEN') ENDIF IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IEND IGL = D%NPTRLS(JSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,JF)=ZRCV(IND) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),JPRBT)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),JPRBT)) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),JPRBT)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),JPRBT)) ENDDO ENDIF DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*KFIELDS+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*KFIELDS ENDIF IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,1,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,JF) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZSND(IND)=ZMING(JF) IND=IND+1 ZSND(IND)=ZMAXG(JF) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZSND(IND)=ZMING(JF) IND=IND+1 ZSND(IND)=ZMAXG(JF) ENDDO ENDIF CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS:V') DEALLOCATE(ZSND) ENDIF ENDIF ENDIF CALL GSTATS(815,1) IF( MYSETW == 1 .AND. MYSETV == 1 )THEN PAVE(:)=0.0_JPRB DO JGL=1,R%NDGL PAVE(:)=PAVE(:)+REAL(ZAVEG(JGL,:),JPRB) ENDDO PMIN(:)=ZMING(:) PMAX(:)=ZMAXG(:) ENDIF DEALLOCATE(ZAVEG) DEALLOCATE(ZMING) DEALLOCATE(ZMAXG) DEALLOCATE(IVSETS) DEALLOCATE(IVSETG) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANS ectrans-1.8.0/src/trans/gpu/external/trans_pnm.F900000775000175000017500000001127215174631767022206 0ustar alastairalastair! (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 TRANS_PNM(KRESOL,KM,PRPNM,LDTRANSPOSE,LDCHEAP) !**** *TRANS_PNM* - Compute Legendre polynomials for a given wavenember ! Purpose. ! -------- ! Interface routine for computing Legendre polynomials for a given wavenember !** Interface. ! ---------- ! CALL TRANS_PNM(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resolution (input) ! KM - wave number ! PRPNM - Legendre polynomials ! LDTRANSPOSE - Legendre polynomials array is transposed ! LDCHEAP - cheapest but less accurate computation ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 22-Jan-2016 from G. Mozdzynski's getpnm ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPRD, JPIM USE PARKIND_ECTRANS, ONLY: JPRBT !ifndef INTERFACE USE TPM_DIM, ONLY: R USE TPM_DISTR, ONLY: D USE TPM_GEOMETRY, ONLY: G USE TPM_FIELDS, ONLY: F USE TPM_FLT, ONLY: S USE SET_RESOL_MOD, ONLY: SET_RESOL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE TPM_POL, ONLY: INI_POL, END_POL USE SUPOLF_MOD, ONLY: SUPOLF !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) ,INTENT(IN) :: KM REAL(KIND=JPRBT) ,OPTIONAL, INTENT(OUT) :: PRPNM(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: LDTRANSPOSE LOGICAL, OPTIONAL, INTENT(IN) :: LDCHEAP !ifndef INTERFACE INTEGER(KIND=JPIM) :: IU1, IU2, IMAXN, INMAX, ICHEAP_SYM, ICHEAP_ANTISYM INTEGER(KIND=JPIM) :: IC, JN, JMLOC, JGL, JI INTEGER(KIND=JPIM) :: IA, IS, IDGLU, ILA, ILS, ISL REAL(KIND=JPRD), ALLOCATABLE :: ZLPOL(:) LOGICAL :: LLTRANSPOSE, LLCHEAP ! ------------------------------------------------------------------ ! Set current resolution IF (PRESENT(KRESOL)) THEN CALL SET_RESOL(KRESOL) ENDIF IF (PRESENT(LDTRANSPOSE)) THEN LLTRANSPOSE=LDTRANSPOSE ELSE LLTRANSPOSE=.FALSE. ENDIF IF (PRESENT(LDCHEAP)) THEN LLCHEAP=LDCHEAP ELSE LLCHEAP=.FALSE. ENDIF IF (LLCHEAP) THEN ICHEAP_SYM =2 ICHEAP_ANTISYM=3 ELSE ICHEAP_SYM =1 ICHEAP_ANTISYM=1 ENDIF IF (PRESENT(PRPNM)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_PNM: PRPNM REQUIRED BUT LGRIDONLY=T') ENDIF ENDIF IU1 = UBOUND(PRPNM,1) IU2 = UBOUND(PRPNM,2) IF (LLTRANSPOSE) THEN IF(IU2 < R%NLEI3) THEN CALL ABORT_TRANS('TRANS_PNM : FIRST DIM. OF PRPNM TOO SMALL') ENDIF IF(IU1 < R%NTMAX-KM+3) THEN CALL ABORT_TRANS('TRANS_PNM : SECOND DIM. OF PRPNM TOO SMALL') ENDIF IF (IU2 >= R%NLEI3) THEN PRPNM(:,R%NLEI3) = 0.0_JPRBT ENDIF ELSE IF(IU1 < R%NLEI3) THEN CALL ABORT_TRANS('TRANS_PNM : FIRST DIM. OF PRPNM TOO SMALL') ENDIF IF(IU2 < R%NTMAX-KM+3) THEN CALL ABORT_TRANS('TRANS_PNM : SECOND DIM. OF PRPNM TOO SMALL') ENDIF IF (IU1 >= R%NLEI3) THEN PRPNM(R%NLEI3,:) = 0.0_JPRBT ENDIF ENDIF ILA = (R%NTMAX-KM+2)/2 ILS = (R%NTMAX-KM+3)/2 CALL INI_POL(R%NTMAX+2,LDFAST=.TRUE.) IMAXN=R%NTMAX+1 IA = 1+MOD(R%NTMAX-KM+2,2) IS = 1+MOD(R%NTMAX-KM+1,2) ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IF (S%LSOUTHPNM) THEN IDGLU = 2*MIN(R%NDGNH,G%NDGLU(KM)) ELSE IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) ENDIF IF(MOD(IMAXN-KM,2) == 0) THEN INMAX=IMAXN+1 ELSE INMAX=IMAXN ENDIF ALLOCATE(ZLPOL(0:R%NTMAX+2)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,ZLPOL,JI,JN) DO JGL=1,IDGLU CALL SUPOLF(KM,INMAX,REAL (F%RMU(ISL+JGL-1), JPRD),ZLPOL(0:INMAX),KCHEAP=ICHEAP_ANTISYM) IF (LLTRANSPOSE) THEN DO JI=1,ILA PRPNM(IA+(JI-1)*2,ISL+JGL-1) = ZLPOL(KM+2*(ILA-JI)+1) ENDDO ELSE DO JI=1,ILA PRPNM(ISL+JGL-1,IA+(JI-1)*2) = ZLPOL(KM+2*(ILA-JI)+1) ENDDO ENDIF CALL SUPOLF(KM,INMAX,REAL (F%RMU(ISL+JGL-1), JPRD),ZLPOL(0:INMAX),KCHEAP=ICHEAP_SYM) IF (LLTRANSPOSE) THEN DO JI=1,ILS PRPNM(IS+(JI-1)*2,ISL+JGL-1) = ZLPOL(KM+2*(ILS-JI)) ENDDO ELSE DO JI=1,ILS PRPNM(ISL+JGL-1,IS+(JI-1)*2) = ZLPOL(KM+2*(ILS-JI)) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL END_POL ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE TRANS_PNM ectrans-1.8.0/src/trans/gpu/external/trans_end.F900000775000175000017500000000637615174631767022173 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2000- Meteo-France. ! (C) Copyright 2022- NVIDIA. ! ! 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 TRANS_END(CDMODE) !**** *TRANS_END* - Terminate transform package ! Purpose. ! -------- ! Terminate transform package. Release all allocated arrays. !** Interface. ! ---------- ! CALL TRANS_END ! Explicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti: 19-03-2009: intermediate end of transf to allow to switch to mono-task transforms ! R. El Khatib 09-Jul-2013 LENABLED ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRB !ifndef INTERFACE USE TPM_GEN, ONLY: MSETUP0, NCUR_RESOL, NMAX_RESOL, LENABLED, NDEF_RESOL USE TPM_DIM, ONLY: R, DIM_RESOL USE TPM_DISTR, ONLY: D, DISTR_RESOL, NPRCIDS USE TPM_GEOMETRY, ONLY: G, GEOM_RESOL USE TPM_FIELDS, ONLY: F, FIELDS_RESOL USE TPM_FIELDS_GPU, ONLY: FG, FIELDS_GPU_RESOL USE TPM_CTL, ONLY: C, CTL_RESOL USE TPM_FLT, ONLY: S, FLT_RESOL USE TPM_TRANS, ONLY: GROWING_ALLOCATION USE GROWING_ALLOCATOR_MOD,ONLY: DESTROY_GROWING_ALLOCATOR USE EQ_REGIONS_MOD, ONLY: N_REGIONS USE SET_RESOL_MOD, ONLY: SET_RESOL USE DEALLOC_RESOL_MOD, ONLY: DEALLOC_RESOL ! IMPLICIT NONE CHARACTER(LEN=5), OPTIONAL, INTENT(IN) :: CDMODE ! Local variables INTEGER(KIND=JPIM) :: JRES CHARACTER(LEN=5) :: CLMODE ! ------------------------------------------------------------------ CLMODE='FINAL' IF (PRESENT(CDMODE)) CLMODE=CDMODE IF (CLMODE == 'FINAL') THEN !CALL HIP_DGEMM_BATCHED_FINALIZE() IF( ALLOCATED( LENABLED ) ) THEN DO JRES=1,NMAX_RESOL IF(LENABLED(JRES)) THEN CALL DEALLOC_RESOL(JRES) ENDIF ENDDO DEALLOCATE(LENABLED) ENDIF CALL DESTROY_GROWING_ALLOCATOR(GROWING_ALLOCATION) NULLIFY(R) IF( ALLOCATED(DIM_RESOL) ) DEALLOCATE(DIM_RESOL) NULLIFY(D) IF( ALLOCATED(DISTR_RESOL) ) DEALLOCATE(DISTR_RESOL) !TPM_FLT NULLIFY(S) IF( ALLOCATED(FLT_RESOL) ) DEALLOCATE(FLT_RESOL) !TPM_CTL NULLIFY(C) IF( ALLOCATED(CTL_RESOL) ) DEALLOCATE(CTL_RESOL) !TPM_FIELDS NULLIFY(F) IF( ALLOCATED(FIELDS_RESOL) ) DEALLOCATE(FIELDS_RESOL) !TPM_FIELDS_GPU NULLIFY(FG) IF( ALLOCATED(FIELDS_GPU_RESOL) ) DEALLOCATE(FIELDS_GPU_RESOL) !TPM_GEOMETRY NULLIFY(G) IF( ALLOCATED(GEOM_RESOL) ) DEALLOCATE(GEOM_RESOL) MSETUP0 = 0 NMAX_RESOL = 0 NCUR_RESOL = 0 NDEF_RESOL = 0 ENDIF IF (CLMODE == 'FINAL' .OR. CLMODE == 'INTER') THEN !EQ_REGIONS IF( ASSOCIATED(N_REGIONS) ) DEALLOCATE(N_REGIONS) !TPM_DISTR IF( ALLOCATED(NPRCIDS) ) DEALLOCATE(NPRCIDS) ENDIF ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE TRANS_END ectrans-1.8.0/src/trans/gpu/CMakeLists.txt0000664000175000017500000002122615174631767020640 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. ## Assemble sources list( APPEND trans_gpu_common_src algor/ext_acc.F90 algor/c_hipmemgetinfo.cpp algor/buffered_allocator_mod.F90 algor/device_mod.F90 algor/growing_allocator_mod.F90 algor/hicblas_mod.F90 internal/tpm_stats.F90 internal/tpm_hicfft.F90 ) if( HAVE_HIP ) set( GPU_RUNTIME "HIP" ) ectrans_declare_hip_sources( SOURCES_GLOB algor/*.hip.cpp ) list( APPEND trans_gpu_common_src algor/hicblas_gemm.hip.cpp algor/hicfft.hip.cpp ) ecbuild_info("warn: IN_PLACE_FFT not defined for hipFFT") elseif( HAVE_CUDA ) set( GPU_RUNTIME "CUDA" ) set( ECTRANS_GPU_HIP_LIBRARIES CUDA::cufft CUDA::cublas nvhpcwrapnvtx CUDA::cudart ) list( APPEND trans_gpu_common_src algor/hicblas_gemm.cuda.cu algor/hicfft.cuda.cu ) ecbuild_info("warn: IN_PLACE_FFT defined for cuFFT") else() ecbuild_info("warn: HIP and CUDA not found") endif() # We can't reliably pass GPU buffers directly to MPL routines yet, so for now we should still use raw MPI calls if( HAVE_GPU_AWARE_MPI ) set( USE_RAW_MPI 1 ) else() set( USE_RAW_MPI 0) endif() set( GPU_LIBRARY_TYPE SHARED ) if( HAVE_GPU_STATIC ) set( GPU_LIBRARY_TYPE STATIC ) endif() ecbuild_add_library( TARGET ectrans_gpu_common TYPE ${GPU_LIBRARY_TYPE} SOURCES ${trans_gpu_common_src} LINKER_LANGUAGE Fortran PUBLIC_INCLUDES $ $ $ $ PUBLIC_LIBS fiat ectrans_common PRIVATE_LIBS ${ECTRANS_GPU_HIP_LIBRARIES} $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> $<${HAVE_OMP}:OpenMP::OpenMP_Fortran> $<${HAVE_CUTLASS}:nvidia::cutlass::cutlass> PRIVATE_DEFINITIONS ${GPU_RUNTIME}GPU ${GPU_OFFLOAD}GPU $<${HAVE_CUTLASS}:USE_CUTLASS> $<${HAVE_CUTLASS_3XTF32}:USE_CUTLASS_3XTF32> $<${HAVE_GPU_GRAPHS_GEMM}:USE_GRAPHS_GEMM> $<${HAVE_GPU_GRAPHS_FFT}:USE_GRAPHS_FFT> ) ecbuild_target_fortran_module_directory( TARGET ectrans_gpu_common MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/module/ectrans INSTALL_MODULE_DIRECTORY module/ectrans ) function(generate_backend_sources) set (options) set (oneValueArgs BACKEND DESTINATION OUTPUT) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(backend ${_PAR_BACKEND}) set(destination ${_PAR_DESTINATION}) file(MAKE_DIRECTORY ${destination}/algor) file(MAKE_DIRECTORY ${destination}/internal) file(MAKE_DIRECTORY ${destination}/external) ecbuild_list_add_pattern( LIST files GLOB internal/*.F90 external/*.F90 QUIET ) list( APPEND files algor/seefmm_mix.F90 ) ecbuild_list_exclude_pattern( LIST files REGEX parkind_ectrans.F90 tpm_stats.F90 tpm_hicfft.F90 ) set(outfiles) foreach(file_i ${files}) get_filename_component(outfile_name ${file_i} NAME) get_filename_component(outfile_name_we ${file_i} NAME_WE) get_filename_component(outfile_ext ${file_i} EXT) get_filename_component(outfile_dir ${file_i} DIRECTORY) set(outfile "${destination}/${file_i}") ecbuild_debug("Generate ${outfile}") generate_file(BACKEND ${backend} INPUT ${CMAKE_CURRENT_SOURCE_DIR}/${file_i} OUTPUT ${outfile}) list(APPEND outfiles ${outfile}) endforeach(file_i) set(${_PAR_OUTPUT} ${outfiles} PARENT_SCOPE) endfunction(generate_backend_sources) set( BUILD_INTERFACE_INCLUDE_DIR ${CMAKE_BINARY_DIR}/include/ectrans ) foreach( prec dp sp ) if( HAVE_${prec} ) set(GENERATED_SOURCE_DIR ${CMAKE_CURRENT_BINARY_DIR}/generated/ectrans_gpu_${prec}) generate_backend_includes(BACKEND gpu_${prec} TARGET ectrans_gpu_${prec}_includes DESTINATION ${BUILD_INTERFACE_INCLUDE_DIR} INCLUDE_DIRECTORY ${PROJECT_SOURCE_DIR}/src/trans/include ) generate_backend_sources( BACKEND gpu_${prec} OUTPUT ectrans_gpu_${prec}_src DESTINATION ${GENERATED_SOURCE_DIR}) #if( NOT ${CMAKE_BUILD_TYPE_CAPS} STREQUAL DEBUG ) set_source_files_properties( ${GENERATED_SOURCE_DIR}/internal/ftinv_mod.F90 PROPERTIES COMPILE_OPTIONS "-O2" ) ecbuild_info("warn: special compile flags ftinv_mod.F90") set_source_files_properties( ${GENERATED_SOURCE_DIR}/internal/ftdir_mod.F90 PROPERTIES COMPILE_OPTIONS "-O2" ) ecbuild_info("warn: special compile flags ftdir_mod.F90") #endif() ecbuild_add_library( TARGET ectrans_gpu_${prec} TYPE ${GPU_LIBRARY_TYPE} SOURCES ${ectrans_gpu_${prec}_src} LINKER_LANGUAGE Fortran PUBLIC_INCLUDES $ $ $ $ PUBLIC_LIBS ectrans_common ectrans_gpu_common ectrans_gpu_${prec}_includes PRIVATE_LIBS ${ECTRANS_GPU_HIP_LIBRARIES} $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> $<${HAVE_OMP}:OpenMP::OpenMP_Fortran> $<${USE_RAW_MPI}:MPI::MPI_Fortran> PRIVATE_DEFINITIONS ${GPU_RUNTIME}GPU ${GPU_OFFLOAD}GPU $<${HAVE_CUTLASS}:USE_CUTLASS> $<${HAVE_CUTLASS_3XTF32}:USE_CUTLASS_3XTF32> $<${HAVE_GPU_GRAPHS_GEMM}:USE_GRAPHS_GEMM> $<${HAVE_GPU_GRAPHS_FFT}:USE_GRAPHS_FFT> $<${HAVE_GPU_AWARE_MPI}:USE_GPU_AWARE_MPI> $<${USE_RAW_MPI}:USE_RAW_MPI> ) ecbuild_target_fortran_module_directory( TARGET ectrans_gpu_${prec} MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/ectrans INSTALL_MODULE_DIRECTORY module/ectrans ) if( prec STREQUAL sp ) target_compile_definitions( ectrans_gpu_${prec} PRIVATE TRANS_SINGLE PARKINDTRANS_SINGLE ) endif() # cuFFT can do in-place FFT, hipFFT cannot if( HAVE_CUDA ) target_compile_definitions( ectrans_gpu_${prec} PRIVATE IN_PLACE_FFT ) endif() if( HAVE_OMP AND CMAKE_Fortran_COMPILER_ID MATCHES Cray ) # Propagate flags as link options for downstream targets. Only required for Cray target_link_options( ectrans_gpu_${prec} INTERFACE $<$:SHELL:${OpenMP_Fortran_FLAGS}> $<$:SHELL:${OpenMP_Fortran_FLAGS}> $<$:SHELL:${OpenMP_Fortran_FLAGS}> ) endif() if( HAVE_ACC AND CMAKE_Fortran_COMPILER_ID MATCHES NVHPC ) # Propagate flags as link options for downstream targets. Only required for NVHPC target_link_options( ectrans_gpu_${prec} INTERFACE $<$:SHELL:${OpenACC_Fortran_FLAGS}> $<$:SHELL:${OpenACC_Fortran_FLAGS}> $<$:SHELL:${OpenACC_Fortran_FLAGS}> ) endif() # This interface library is for backward compatibility, and provides the older includes ecbuild_add_library( TARGET trans_gpu_${prec} TYPE INTERFACE ) target_include_directories( trans_gpu_${prec} INTERFACE $ ) target_include_directories( trans_gpu_${prec} INTERFACE $ ) target_link_libraries( trans_gpu_${prec} INTERFACE fiat ectrans_gpu_${prec} parkind_${prec}) # ## Install trans_gpu_${prec} interface # file( GLOB trans_interface ${PROJECT_SOURCE_DIR}/src/trans/include/ectrans/* ) # install( # FILES ${trans_interface} # DESTINATION include/ectrans/trans_gpu_${prec} # ) endif() endforeach() ectrans-1.8.0/src/trans/cpu/0000775000175000017500000000000015174631767016071 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/internal/0000775000175000017500000000000015174631767017705 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/internal/prfi1_mod.F900000664000175000017500000000631215174631767022047 0ustar alastairalastair! (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. ! MODULE PRFI1_MOD CONTAINS SUBROUTINE PRFI1(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& & KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB !USE TPM_DISTR !USE TPM_TRANS USE PRFI1B_MOD ,ONLY : PRFI1B !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPVOR - vorticity ! PSPDIV - divergence ! PSPSCALAR - scalar variables ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1 in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PIA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! ------------------------------------ IFIRST = 1 ILAST = 4*KF_UV !* 1.1 VORTICITY AND DIVERGENCE. IF(KF_UV > 0)THEN IVOR = 1 IDIV = 2*KF_UV+1 CALL PRFI1B(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) CALL PRFI1B(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV ENDIF !* 1.2 SCALAR VARIABLES. IF(KF_SCALARS > 0)THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL PRFI1B(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE PRFI1 END MODULE PRFI1_MOD ectrans-1.8.0/src/trans/cpu/internal/tpm_fftw.F900000664000175000017500000003552715174631767022027 0ustar alastairalastair! (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. ! MODULE TPM_FFTW ! Author. ! ------- ! George Mozdzynski ! ! Modifications. ! -------------- ! Original October 2014 ! R. El Khatib 01-Sep-2015 More subroutines for better modularity ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility USE, INTRINSIC :: ISO_C_BINDING USE PARKIND1 ,ONLY : JPIB, JPIM, JPRB, JPRD USE MPL_MODULE ,ONLY : MPL_MYRANK USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE SAVE #ifdef __NEC__ ! From NLC (NEC Numeric Library Collection) #include "aslfftw3.f03" #define FFTW_NO_SIMD 0 #else #include "fftw3.f03" #endif PRIVATE PUBLIC CREATE_PLAN_FFTW, DESTROY_PLAN_FFTW, DESTROY_PLANS_FFTW, INIT_PLANS_FFTW, & & FFTW_RESOL, TW, EXEC_FFTW, EXEC_EFFTW TYPE FFTW_TYPE INTEGER(KIND=JPIM),ALLOCATABLE :: N_PLANS(:) TYPE(FFTW_PLAN),POINTER :: FFTW_PLANS(:) => NULL() INTEGER(KIND=JPIM) :: N_MAX=0 ! maximum number of latitudes INTEGER(KIND=JPIM) :: N_MAX_PLANS=4 ! maximum number of plans for each active latitude LOGICAL :: LALL_FFTW=.FALSE. ! T=do kfields ffts in one batch, F=do kfields ffts one at a time END TYPE FFTW_TYPE TYPE FFTW_PLAN INTEGER(KIND=JPIM) :: NPLAN_ID=123456 INTEGER(KIND=JPIB) :: NPLAN INTEGER(KIND=JPIM) :: NLOT INTEGER(KIND=JPIM) :: NTYPE TYPE(FFTW_PLAN),POINTER :: NEXT_PLAN => NULL() END TYPE FFTW_PLAN TYPE(FFTW_TYPE),ALLOCATABLE,TARGET :: FFTW_RESOL(:) TYPE(FFTW_TYPE),POINTER :: TW ! ------------------------------------------------------------------ CONTAINS ! ------------------------------------------------------------------ SUBROUTINE INIT_PLANS_FFTW(KDLON) INTEGER(KIND=JPIM),INTENT(IN) :: KDLON #include "abor1.intfb.h" TW%N_MAX=KDLON ALLOCATE(TW%FFTW_PLANS(TW%N_MAX)) ALLOCATE(TW%N_PLANS(TW%N_MAX)) TW%N_PLANS(:)=0 RETURN END SUBROUTINE INIT_PLANS_FFTW SUBROUTINE CREATE_PLAN_FFTW(KPLAN,KTYPE,KN,KLOT) INTEGER(KIND=JPIB),INTENT(OUT) :: KPLAN INTEGER(KIND=JPIM),INTENT(IN) :: KTYPE,KN,KLOT INTEGER(KIND=JPIB) :: IPLAN INTEGER(KIND=JPIM) :: IRANK, ISTRIDE INTEGER(KIND=JPIM) :: JL INTEGER(KIND=JPIM) :: IRDIST,ICDIST,IN(1),IEMBED(1) REAL(KIND=JPRB), POINTER :: ZDUM(:) TYPE(C_PTR) :: ZDUMP LOGICAL :: LLFOUND LOGICAL, PARAMETER :: LLRESTRICT_PLANS=.TRUE. TYPE(FFTW_PLAN),POINTER :: CURR_FFTW_PLAN,START_FFTW_PLAN REAL(KIND=JPHOOK) :: ZHOOK_HANDLE, ZHOOK_HANDLE2 IF (LHOOK) CALL DR_HOOK('CREATE_PLAN_FFTW',0,ZHOOK_HANDLE) IF( KN > TW%N_MAX )THEN CALL ABOR1('CREATE_PLAN_FFTW: KN > N_MAX THAT WAS INITIALISED IN INIT_PLANS_FFTW') ENDIF IRANK=1 ISTRIDE=1 IN(1)=KN IEMBED(1)=IN(1) ICDIST=KN/2+1 IRDIST=ICDIST*2 !$OMP CRITICAL (FFTW_CREATE) LLFOUND=.FALSE. IF( TW%FFTW_PLANS(KN)%NPLAN_ID /= 123456 )THEN WRITE(*,'("CREATE_PLAN_FFTW.1: PLAN_ID=",I10)')TW%FFTW_PLANS(KN)%NPLAN_ID CALL ABOR1('CREATE_PLAN_FFTW.1: NPLAN_ID /= 123456') ENDIF CURR_FFTW_PLAN=>TW%FFTW_PLANS(KN) IF( CURR_FFTW_PLAN%NPLAN_ID /= 123456 )THEN WRITE(*,'("CREATE_PLAN_FFTW.2: PLAN_ID=",I10)')CURR_FFTW_PLAN%NPLAN_ID CALL ABOR1('CREATE_PLAN_FFTW.2: NPLAN_ID /= 123456') ENDIF ! search for plan in existing plans DO JL=1,TW%N_PLANS(KN) IF( KLOT == CURR_FFTW_PLAN%NLOT .AND. KTYPE == CURR_FFTW_PLAN%NTYPE )THEN LLFOUND=.TRUE. IPLAN=CURR_FFTW_PLAN%NPLAN EXIT ELSEIF( JL /= TW%N_PLANS(KN) )THEN CURR_FFTW_PLAN=>CURR_FFTW_PLAN%NEXT_PLAN IF( CURR_FFTW_PLAN%NPLAN_ID /= 123456 )THEN WRITE(*,'("CREATE_PLAN_FFTW.3: PLAN_ID=",I10)')CURR_FFTW_PLAN%NPLAN_ID CALL ABOR1('CREATE_PLAN_FFTW.3: NPLAN_ID /= 123456') ENDIF ENDIF ENDDO IF( .NOT.LLFOUND )THEN IF( LLRESTRICT_PLANS )THEN IF( TW%N_PLANS(KN) == TW%N_MAX_PLANS )THEN ! destroy the plan at the start of the list ! WRITE(*,'("CREATE_PLAN_FFTW: BEG: DESTROYING A PLAN AT THE START OF THE LIST")') IF (JPRB == JPRD) THEN CALL DFFTW_DESTROY_PLAN(TW%FFTW_PLANS(KN)%NPLAN) ELSE CALL SFFTW_DESTROY_PLAN(TW%FFTW_PLANS(KN)%NPLAN) END IF TW%FFTW_PLANS(KN)%NPLAN_ID=999999 START_FFTW_PLAN=>TW%FFTW_PLANS(KN) TW%FFTW_PLANS(KN)=TW%FFTW_PLANS(KN)%NEXT_PLAN ! DEALLOCATE(START_FFTW_PLAN) TW%N_PLANS(KN)=TW%N_PLANS(KN)-1 ! WRITE(*,'("CREATE_PLAN_FFTW: END: DESTROYING A PLAN AT THE START OF THE LIST")') ENDIF ENDIF IF (JPRB == JPRD) THEN ZDUMP=FFTW_ALLOC_COMPLEX(INT(1,C_SIZE_T)) ELSE ZDUMP=FFTWF_ALLOC_COMPLEX(INT(1,C_SIZE_T)) END IF CALL C_F_POINTER(ZDUMP,ZDUM,[2]) IF( KTYPE==1 )THEN IF (LHOOK) CALL DR_HOOK('FFTW_PLAN_MANY_DFT_C2R',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_PLAN_MANY_DFT_C2R(IPLAN,IRANK,IN,KLOT,ZDUM,IEMBED,ISTRIDE,ICDIST,& & ZDUM,IEMBED,ISTRIDE,IRDIST,FFTW_ESTIMATE+FFTW_NO_SIMD) ELSE CALL SFFTW_PLAN_MANY_DFT_C2R(IPLAN,IRANK,IN,KLOT,ZDUM,IEMBED,ISTRIDE,ICDIST,& & ZDUM,IEMBED,ISTRIDE,IRDIST,FFTW_ESTIMATE+FFTW_NO_SIMD) END IF IF (LHOOK) CALL DR_HOOK('FFTW_PLAN_MANY_DFT_C2R',1,ZHOOK_HANDLE2) ELSEIF( KTYPE==-1 )THEN IF (LHOOK) CALL DR_HOOK('FFTW_PLAN_MANY_DFT_R2C',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_PLAN_MANY_DFT_R2C(IPLAN,IRANK,IN,KLOT,ZDUM,IEMBED,ISTRIDE,IRDIST,& & ZDUM,IEMBED,ISTRIDE,ICDIST,FFTW_ESTIMATE+FFTW_NO_SIMD) ELSE CALL SFFTW_PLAN_MANY_DFT_R2C(IPLAN,IRANK,IN,KLOT,ZDUM,IEMBED,ISTRIDE,IRDIST,& & ZDUM,IEMBED,ISTRIDE,ICDIST,FFTW_ESTIMATE+FFTW_NO_SIMD) END IF IF (LHOOK) CALL DR_HOOK('FFTW_PLAN_MANY_DFT_R2C',1,ZHOOK_HANDLE2) ELSE CALL ABOR1('FFTW_PLAN: INVALID KTYPE') ENDIF IF (JPRB == JPRD) THEN CALL FFTW_FREE(ZDUMP) ELSE CALL FFTWF_FREE(ZDUMP) END IF KPLAN=IPLAN TW%N_PLANS(KN)=TW%N_PLANS(KN)+1 IF( TW%N_PLANS(KN) /= 1 )THEN ALLOCATE(CURR_FFTW_PLAN%NEXT_PLAN) CURR_FFTW_PLAN=>CURR_FFTW_PLAN%NEXT_PLAN ENDIF IF( CURR_FFTW_PLAN%NPLAN_ID /= 123456 )THEN WRITE(*,'("CREATE_PLAN_FFTW.4: PLAN_ID=",I10)')CURR_FFTW_PLAN%NPLAN_ID CALL ABOR1('CREATE_PLAN_FFTW.4: NPLAN_ID /= 123456') ENDIF CURR_FFTW_PLAN%NPLAN=IPLAN CURR_FFTW_PLAN%NLOT=KLOT CURR_FFTW_PLAN%NTYPE=KTYPE CURR_FFTW_PLAN%NEXT_PLAN=>NULL() ! write(*,'("CREATE_PLAN_FFTW: KN=",I5," NPLANS=",I3," KLOT=",I6," KTYPE=",I2,& ! & " NEW IPLAN=",Z16)')KN,TW%N_PLANS(KN),KLOT,KTYPE,IPLAN ELSE KPLAN=IPLAN ! write(*,'("CREATE_PLAN_FFTW: KN=",I5," NPLANS=",I3," KLOT=",I6," KTYPE=",I2,& ! & " CUR IPLAN=",Z16)')KN,TW%N_PLANS(KN),KLOT,KTYPE,IPLAN ENDIF !$OMP END CRITICAL (FFTW_CREATE) IF (LHOOK) CALL DR_HOOK('CREATE_PLAN_FFTW',1,ZHOOK_HANDLE) RETURN END SUBROUTINE CREATE_PLAN_FFTW SUBROUTINE DESTROY_PLAN_FFTW(KPLAN) INTEGER(KIND=JPIB),INTENT(IN) :: KPLAN !$OMP CRITICAL (FFTW_DESTROY) IF (JPRB == JPRD) THEN CALL DFFTW_DESTROY_PLAN(KPLAN) ELSE CALL SFFTW_DESTROY_PLAN(KPLAN) END IF !$OMP END CRITICAL (FFTW_DESTROY) RETURN END SUBROUTINE DESTROY_PLAN_FFTW SUBROUTINE DESTROY_PLANS_FFTW INTEGER(KIND=JPIM) :: JL, JN TYPE(FFTW_PLAN),POINTER :: CURR_FFTW_PLAN, NEXT_FFTW_PLAN DO JN=1,TW%N_MAX CURR_FFTW_PLAN=>TW%FFTW_PLANS(JN) DO JL=1,TW%N_PLANS(JN) CALL DESTROY_PLAN_FFTW(CURR_FFTW_PLAN%NPLAN) NEXT_FFTW_PLAN=>CURR_FFTW_PLAN%NEXT_PLAN IF( JL /= 1 ) THEN DEALLOCATE( CURR_FFTW_PLAN ) ENDIF CURR_FFTW_PLAN => NEXT_FFTW_PLAN ENDDO ENDDO IF( ASSOCIATED(TW) ) THEN IF( ASSOCIATED(TW%FFTW_PLANS) ) DEALLOCATE(TW%FFTW_PLANS) IF( ALLOCATED(TW%N_PLANS) ) DEALLOCATE(TW%N_PLANS) TW%N_MAX=0 ENDIF RETURN END SUBROUTINE DESTROY_PLANS_FFTW SUBROUTINE EXEC_FFTW(KTYPE,KRLEN,KCLEN,KOFF,KFIELDS,LD_ALL,PREEL) INTEGER(KIND=JPIM),INTENT(IN) :: KTYPE INTEGER(KIND=JPIM),INTENT(IN) :: KRLEN INTEGER(KIND=JPIM),INTENT(IN) :: KCLEN INTEGER(KIND=JPIM),INTENT(IN) :: KOFF INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS LOGICAL ,INTENT(IN) :: LD_ALL REAL(KIND=JPRB), INTENT(INOUT) :: PREEL(:,:) REAL(KIND=JPRB), POINTER :: ZFFT(:,:) REAL(KIND=JPRB), POINTER :: ZFFT1(:) TYPE(C_PTR) :: ZFFTP, ZFFT1P INTEGER(KIND=JPIM) :: JJ,JF INTEGER(KIND=JPIB) :: IPLAN_C2R, IPLAN_C2R1 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE, ZHOOK_HANDLE2 #include "abor1.intfb.h" IF (LHOOK) CALL DR_HOOK('EXEC_FFTW',0,ZHOOK_HANDLE) IF ( (KTYPE /= -1) .AND. (KTYPE /=1) ) THEN CALL ABOR1('TPM_FFTW:EXEC_FFTW : WRONG VALUE KTYPE') ENDIF IF( LD_ALL )THEN CALL CREATE_PLAN_FFTW(IPLAN_C2R,KTYPE,KRLEN,KFIELDS) IF (JPRB == JPRD) THEN ZFFTP=FFTW_ALLOC_COMPLEX(INT(KCLEN/2*KFIELDS,C_SIZE_T)) ELSE ZFFTP=FFTWF_ALLOC_COMPLEX(INT(KCLEN/2*KFIELDS,C_SIZE_T)) END IF CALL C_F_POINTER(ZFFTP,ZFFT,[KCLEN,KFIELDS]) IF (KTYPE==1) THEN DO JF=1,KFIELDS DO JJ=1,KCLEN ZFFT(JJ,JF) =PREEL(JF,KOFF+JJ-1) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_C2R(IPLAN_C2R,ZFFT,ZFFT) ELSE CALL SFFTW_EXECUTE_DFT_C2R(IPLAN_C2R,ZFFT,ZFFT) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',1,ZHOOK_HANDLE2) DO JJ=1,KRLEN DO JF=1,KFIELDS PREEL(JF,KOFF+JJ-1)=ZFFT(JJ,JF) ENDDO ENDDO ELSE DO JF=1,KFIELDS DO JJ=1,KRLEN ZFFT(JJ,JF) =PREEL(JF,KOFF+JJ-1) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_R2C(IPLAN_C2R,ZFFT,ZFFT) ELSE CALL SFFTW_EXECUTE_DFT_R2C(IPLAN_C2R,ZFFT,ZFFT) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',1,ZHOOK_HANDLE2) DO JJ=1,KCLEN DO JF=1,KFIELDS PREEL(JF,KOFF+JJ-1)=ZFFT(JJ,JF)/REAL(KRLEN,JPRB) ENDDO ENDDO ENDIF IF (JPRB == JPRD) THEN CALL FFTW_FREE(ZFFTP) ELSE CALL FFTWF_FREE(ZFFTP) END IF ELSE CALL CREATE_PLAN_FFTW(IPLAN_C2R1,KTYPE,KRLEN,1) IF (JPRB == JPRD) THEN ZFFT1P=FFTW_ALLOC_COMPLEX(INT(KCLEN/2,C_SIZE_T)) ELSE ZFFT1P=FFTWF_ALLOC_COMPLEX(INT(KCLEN/2,C_SIZE_T)) END IF CALL C_F_POINTER(ZFFT1P,ZFFT1,[KCLEN]) IF (KTYPE==1) THEN DO JF=1,KFIELDS DO JJ=1,KCLEN ZFFT1(JJ) =PREEL(JF,KOFF+JJ-1) ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_C2R(IPLAN_C2R1,ZFFT1,ZFFT1) ELSE CALL SFFTW_EXECUTE_DFT_C2R(IPLAN_C2R1,ZFFT1,ZFFT1) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',1,ZHOOK_HANDLE2) DO JJ=1,KRLEN PREEL(JF,KOFF+JJ-1)=ZFFT1(JJ) ENDDO ENDDO ELSE DO JF=1,KFIELDS DO JJ=1,KRLEN ZFFT1(JJ) =PREEL(JF,KOFF+JJ-1) ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_R2C(IPLAN_C2R1,ZFFT1,ZFFT1) ELSE CALL SFFTW_EXECUTE_DFT_R2C(IPLAN_C2R1,ZFFT1,ZFFT1) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',1,ZHOOK_HANDLE2) DO JJ=1,KCLEN PREEL(JF,KOFF+JJ-1)=ZFFT1(JJ)/REAL(KRLEN,JPRB) ENDDO ENDDO ENDIF IF (JPRB == JPRD) THEN CALL FFTW_FREE(ZFFT1P) ELSE CALL FFTWF_FREE(ZFFT1P) END IF ENDIF IF (LHOOK) CALL DR_HOOK('EXEC_FFTW',1,ZHOOK_HANDLE) END SUBROUTINE EXEC_FFTW SUBROUTINE EXEC_EFFTW(KTYPE,KRLEN,KCLEN,KOFF,KFIELDS,LD_ALL,PREEL) INTEGER(KIND=JPIM),INTENT(IN) :: KTYPE INTEGER(KIND=JPIM),INTENT(IN) :: KRLEN INTEGER(KIND=JPIM),INTENT(IN) :: KCLEN INTEGER(KIND=JPIM),INTENT(IN) :: KOFF INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS LOGICAL ,INTENT(IN) :: LD_ALL REAL(KIND=JPRB), INTENT(INOUT) :: PREEL(:,:) REAL(KIND=JPRB), POINTER :: ZFFT(:,:) REAL(KIND=JPRB), POINTER :: ZFFT1(:) TYPE(C_PTR) :: ZFFTP, ZFFT1P INTEGER(KIND=JPIM) :: JJ,JF INTEGER(KIND=JPIB) :: IPLAN_C2R, IPLAN_C2R1 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE, ZHOOK_HANDLE2 #include "abor1.intfb.h" IF (LHOOK) CALL DR_HOOK('EXEC_EFFTW',0,ZHOOK_HANDLE) IF ( (KTYPE /= -1) .AND. (KTYPE /=1) ) THEN CALL ABOR1('TPM_FFTW:EXEC_EFFTW : WRONG VALUE KTYPE') ENDIF IF( LD_ALL )THEN CALL CREATE_PLAN_FFTW(IPLAN_C2R,KTYPE,KRLEN,KFIELDS) IF (JPRB == JPRD) THEN ZFFTP=FFTW_ALLOC_COMPLEX(INT(KCLEN/2*KFIELDS,C_SIZE_T)) ELSE ZFFTP=FFTWF_ALLOC_COMPLEX(INT(KCLEN/2*KFIELDS,C_SIZE_T)) END IF CALL C_F_POINTER(ZFFTP,ZFFT,[KCLEN,KFIELDS]) IF (KTYPE==1) THEN DO JF=1,KFIELDS DO JJ=1,KCLEN ZFFT(JJ,JF) =PREEL(KOFF+JJ-1,JF) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_C2R(IPLAN_C2R,ZFFT,ZFFT) ELSE CALL SFFTW_EXECUTE_DFT_C2R(IPLAN_C2R,ZFFT,ZFFT) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',1,ZHOOK_HANDLE2) DO JF=1,KFIELDS DO JJ=1,KRLEN PREEL(KOFF+JJ-1,JF)=ZFFT(JJ,JF) ENDDO ENDDO ELSE DO JF=1,KFIELDS DO JJ=1,KRLEN ZFFT(JJ,JF) =PREEL(KOFF+JJ-1,JF) ENDDO ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_R2C(IPLAN_C2R,ZFFT,ZFFT) ELSE CALL SFFTW_EXECUTE_DFT_R2C(IPLAN_C2R,ZFFT,ZFFT) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',1,ZHOOK_HANDLE2) DO JF=1,KFIELDS DO JJ=1,KCLEN PREEL(KOFF+JJ-1,JF)=ZFFT(JJ,JF)/REAL(KRLEN,JPRB) ENDDO ENDDO ENDIF IF (JPRB == JPRD) THEN CALL FFTW_FREE(ZFFTP) ELSE CALL FFTWF_FREE(ZFFTP) END IF ELSE CALL CREATE_PLAN_FFTW(IPLAN_C2R1,KTYPE,KRLEN,1) IF (JPRB == JPRD) THEN ZFFT1P=FFTW_ALLOC_COMPLEX(INT(KCLEN/2,C_SIZE_T)) ELSE ZFFT1P=FFTWF_ALLOC_COMPLEX(INT(KCLEN/2,C_SIZE_T)) END IF CALL C_F_POINTER(ZFFT1P,ZFFT1,[KCLEN]) IF (KTYPE==1) THEN DO JF=1,KFIELDS DO JJ=1,KCLEN ZFFT1(JJ) =PREEL(KOFF+JJ-1,JF) ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_C2R(IPLAN_C2R1,ZFFT1,ZFFT1) ELSE CALL SFFTW_EXECUTE_DFT_C2R(IPLAN_C2R1,ZFFT1,ZFFT1) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_C2R',1,ZHOOK_HANDLE2) DO JJ=1,KRLEN PREEL(KOFF+JJ-1,JF)=ZFFT1(JJ) ENDDO ENDDO ELSE DO JF=1,KFIELDS DO JJ=1,KRLEN ZFFT1(JJ) =PREEL(KOFF+JJ-1,JF) ENDDO IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',0,ZHOOK_HANDLE2) IF (JPRB == JPRD) THEN CALL DFFTW_EXECUTE_DFT_R2C(IPLAN_C2R1,ZFFT1,ZFFT1) ELSE CALL SFFTW_EXECUTE_DFT_R2C(IPLAN_C2R1,ZFFT1,ZFFT1) END IF IF (LHOOK) CALL DR_HOOK('FFTW_EXECUTE_DFT_R2C',1,ZHOOK_HANDLE2) DO JJ=1,KCLEN PREEL(KOFF+JJ-1,JF)=ZFFT1(JJ)/REAL(KRLEN,JPRB) ENDDO ENDDO ENDIF IF (JPRB == JPRD) THEN CALL FFTW_FREE(ZFFT1P) ELSE CALL FFTWF_FREE(ZFFT1P) END IF ENDIF IF (LHOOK) CALL DR_HOOK('EXEC_EFFTW',1,ZHOOK_HANDLE) END SUBROUTINE EXEC_EFFTW END MODULE TPM_FFTW ectrans-1.8.0/src/trans/cpu/internal/cdmap_mod.F900000664000175000017500000001240115174631767022106 0ustar alastairalastair! (C) Copyright 2014- ECMWF. ! (C) Copyright 2014- 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. ! MODULE CDMAP_MOD CONTAINS SUBROUTINE CDMAP(KM,KMLOC,KSL,KSLO,PEPSNM, KDIR, KDGNH, KDGNHD,& & KFIELDS, PCOEFA, PCOEFS) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_FLT ,ONLY : S USE TPM_DISTR ,ONLY : D USE TPM_TRANS ,ONLY : FOUBUF_IN, FOUBUF USE SEEFMM_MIX ,ONLY : SEEFMM_MULM !**** *CDMAP* - REMAP ROOTS ! ! Purpose. ! -------- ! remap from one set of roots to another using Christoffel-Darboux formula, see Chien + Alpert, 1997. !** Interface. ! ---------- ! *CALL* *CDMAP(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! Chien + Alpert, 1997. ! Author. ! ------- ! Nils Wedi *ECMWF* ! Modifications. ! -------------- ! Original : 14-05-14 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KSL INTEGER(KIND=JPIM), INTENT(IN) :: KSLO REAL(KIND=JPRB), INTENT(IN) :: PEPSNM INTEGER(KIND=JPIM), INTENT(IN) :: KDIR ! direction of map INTEGER(KIND=JPIM), INTENT(IN) :: KDGNH INTEGER(KIND=JPIM), INTENT(IN) :: KDGNHD INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS REAL(KIND=JPRB), INTENT(INOUT) :: PCOEFA(:,:) REAL(KIND=JPRB), INTENT(INOUT) :: PCOEFS(:,:) INTEGER(KIND=JPIM) :: JGL, IGL, JF REAL(KIND=JPRB), ALLOCATABLE :: ZALL(:,:), ZQX(:,:) REAL(KIND=JPRB), ALLOCATABLE :: ZALL1(:,:), ZQY(:,:) INTEGER(KIND=JPIM) :: ISTN(KDGNH), ISTS(KDGNH) INTEGER(KIND=JPIM) :: IGLS, IPROC, IPROCS, IEND, IENDO REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('CDMAP_MOD',0,ZHOOK_HANDLE) IF( KDIR == -1 ) THEN ! inverse map from internal (gg) roots to post-processing roots IENDO = 2*KDGNHD - KSLO + 1 IEND = 2*KDGNH - KSL + 1 !!!!! fourier buffer setup in output latitudes, may not work if different from input !!!! DO IGL=KSLO, KDGNHD IPROC = D%NPROCL(IGL) ISTN(IGL) = (D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,IGL))*KFIELDS IGLS = 2*KDGNH+1-IGL IPROCS = D%NPROCL(IGLS) ISTS(IGL) = (D%NSTAGT0B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*KFIELDS ENDDO ALLOCATE(ZALL(KFIELDS, 2*KDGNHD)) ALLOCATE(ZALL1(KFIELDS, 2*KDGNHD)) ALLOCATE(ZQX(KFIELDS, 2*KDGNH)) ALLOCATE(ZQY(KFIELDS, 2*KDGNH)) ZQX(:,1:KSL) = 0._JPRB ZQX(:,IEND:2*KDGNH) = 0._JPRB ZQY(:,1:KSL) = 0._JPRB ZQY(:,IEND:2*KDGNH) = 0._JPRB DO JGL=KSL, IEND ZQX(1:KFIELDS,JGL)=S%FA(KMLOC)%RPNMWI(JGL-KSL+1,1)*PCOEFA(1:KFIELDS,JGL) ZQY(1:KFIELDS,JGL)=S%FA(KMLOC)%RPNMWI(JGL-KSL+1,2)*PCOEFA(1:KFIELDS,JGL) ENDDO CALL SEEFMM_MULM(S%FMM_INTI,KFIELDS,1_JPIM,.TRUE.,ZQX,ZALL1) CALL SEEFMM_MULM(S%FMM_INTI,KFIELDS,1_JPIM,.TRUE.,ZQY,ZALL) DEALLOCATE(ZQX) DEALLOCATE(ZQY) ! minus sign comes from FMM ?! ! fill buffer DO IGL=KSLO,KDGNHD IGLS = 2*KDGNHD+1-IGL DO JF=1,KFIELDS FOUBUF_IN(ISTN(IGL)+JF) = S%FA(KMLOC)%RPNMWO(IGL-KSLO+1,1)*ZALL1(JF,IGL) & & - S%FA(KMLOC)%RPNMWO(IGL-KSLO+1,2)*ZALL(JF,IGL) FOUBUF_IN(ISTS(IGL)+JF) = S%FA(KMLOC)%RPNMWO(IGLS-KSLO+1,1)*ZALL1(JF,IGLS) & & - S%FA(KMLOC)%RPNMWO(IGLS-KSLO+1,2)*ZALL(JF,IGLS) ENDDO ENDDO DEALLOCATE(ZALL1) DEALLOCATE(ZALL) ELSE ! direct map from post-processing/input field roots to internal (gg) roots ! this assumes essentially a nearest neighbour interpolation in latitude ! a more accurate approach may be ! a local gridpoint interpolation of the input field to the target latitudes prior to the transforms IENDO = 2*KDGNHD - KSLO + 1 IEND = 2*KDGNH - KSL + 1 !!!!! fourier buffer setup in input data latitudes, may not work if different from output !!!! DO JGL=KSLO, KDGNHD IPROC = D%NPROCL(JGL) ISTN(JGL) = (D%NSTAGT1B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*KFIELDS IGLS = 2*KDGNHD+1-JGL IPROCS = D%NPROCL(IGLS) ISTS(JGL) = (D%NSTAGT1B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*KFIELDS ENDDO ALLOCATE( ZQX( KFIELDS, 2*KDGNHD)) ZQX(:,1:KSLO) = 0._JPRB ZQX(:,IENDO:2*KDGNHD) = 0._JPRB DO JGL=KSLO, KDGNHD IGLS = 2*KDGNHD+1-JGL DO JF=1,KFIELDS ZQX(JF,JGL)=FOUBUF(ISTN(JGL)+JF) ZQX(JF,IGLS)=FOUBUF(ISTS(JGL)+JF) ENDDO ENDDO ! split into symmetric / antisymmetric DO IGL=KSL,KDGNH IGLS = 2*KDGNH+1-IGL PCOEFS(1:KFIELDS,IGL) = ZQX(1:KFIELDS,IGL) + ZQX(1:KFIELDS,IGLS) PCOEFA(1:KFIELDS,IGL) = ZQX(1:KFIELDS,IGL) - ZQX(1:KFIELDS,IGLS) ENDDO DEALLOCATE(ZQX) ENDIF IF (LHOOK) CALL DR_HOOK('CDMAP_MOD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE CDMAP END MODULE CDMAP_MOD ectrans-1.8.0/src/trans/cpu/internal/fourier_inad_mod.F900000664000175000017500000000475715174631767023507 0ustar alastairalastair! (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. ! MODULE FOURIER_INAD_MOD CONTAINS SUBROUTINE FOURIER_INAD(PREEL, KFIELDS, KGL) !**** *FOURIER_INAD* - Copy fourier data from buffer to local array - adjoint ! Purpose. ! -------- ! Routine for copying fourier data from buffer to local array !** Interface. ! ---------- ! CALL FOURIER_INAD(...) ! Explicit arguments : PREEL - local fourier/GP array ! -------------------- KFIELDS - number of fields ! KGL - local index of latitude we are currently on ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND1, ONLY : JPIM, JPRB USE TPM_DISTR, ONLY : D, MYSETW USE TPM_TRANS, ONLY : FOUBUF USE TPM_GEOMETRY, ONLY : G IMPLICIT NONE REAL(KIND=JPRB), INTENT(IN) :: PREEL(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KGL INTEGER(KIND=JPIM) :: JM, JF, IGLG, IPROC, IR, II, ISTA ! ------------------------------------------------------------------ ! Determine global latitude index corresponding to local latitude index KGL IGLG = D%NPTRLS(MYSETW) + KGL - 1 ! Loop over all zonal wavenumbers relevant for this latitude DO JM = 0, G%NMEN(IGLG) ! Get the member of the W-set responsible for this zonal wavenumber in the "m" representation IPROC = D%NPROCM(JM) ! Compute offset in FFT work array PREEL corresponding to wavenumber JM and latitude KGL IR = 2 * JM + 1 + D%NSTAGTF(KGL) II = 2 * JM + 2 + D%NSTAGTF(KGL) ! Compute offset for insertion of the fields in the m-to-l transposition buffer, FOUBUF ISTA = (D%NSTAGT0B(D%MSTABF(IPROC)) + D%NPNTGTB0(JM,KGL)) * 2 * KFIELDS ! Copy all fields from FFT work array to m-to-l transposition buffer DO JF = 1, KFIELDS FOUBUF(ISTA+2*JF-1) = PREEL(JF,IR) FOUBUF(ISTA+2*JF) = PREEL(JF,II) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FOURIER_INAD END MODULE FOURIER_INAD_MODectrans-1.8.0/src/trans/cpu/internal/gath_grid_32_ctl_mod.F900000664000175000017500000001714415174631767024131 0ustar alastairalastair! (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. ! MODULE GATH_GRID_32_CTL_MOD CONTAINS SUBROUTINE GATH_GRID_32_CTL(PGPG,KFGATHG,KPROMA,KTO,PGP) !**** *GATH_GRID_32_CTL* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Routine for gathering gridpoint array !** Interface. ! ---------- ! CALL GATH_GRID_32_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! PGP(:,:,:) - Local spectral array ! ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRM USE MPL_MODULE USE TPM_GEOMETRY, ONLY: G USE TPM_DISTR, ONLY: D, NPROC, MTAGDISTSP, NPRCIDS, MYPROC USE SET2PE_MOD, ONLY: SET2PE USE EQ_REGIONS_MOD, ONLY: N_REGIONS_NS, N_REGIONS IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) REAL(KIND=JPRM) , INTENT(IN) :: PGP(:,:,:) ! Declaration of local variables REAL(KIND=JPRM) :: ZFLD(D%NGPTOTMX*KFGATHG) REAL(KIND=JPRM),ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) :: IFLDR,JFLD,ITAG,ILEN,JA,JB,ISND,JGL,JLON,ILOFF INTEGER(KIND=JPIM) :: IRCV,IOFF,ILAST,IGL1,IGL2,IGLOFF INTEGER(KIND=JPIM) :: JKGLO,JROF,IEND,J,IBL,IPROC,JROC,IMYFIELDS,ILRECV INTEGER(KIND=JPIM) :: ISENDREQ(NPROC),ITO INTEGER(KIND=JPIM) :: ILENS(NPROC),IOFFS(NPROC),ILENR(NPROC),IOFFR(NPROC) INTEGER(KIND=JPIM) :: IFLDL,IFLDS LOGICAL :: LLSAME ! ------------------------------------------------------------------ !GATHER SPECTRAL ARRAY IF( NPROC == 1 ) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFGATHG DO JROF=1,IEND PGPG(IOFF+JROF,JFLD) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ! test if values in KTO are all the same LLSAME=.TRUE. ITO=KTO(1) DO JFLD=2,KFGATHG IF(KTO(JFLD) /= ITO) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO IFLDL=D%NGPTOTMX IF(LLSAME) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JFLD=1,KFGATHG DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+(JFLD-1)*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ILENS(:)=0 IOFFS(:)=0 ILENR(:)=0 IOFFR(:)=0 DO JFLD=1,KFGATHG ILENS(KTO(JFLD))=ILENS(KTO(JFLD))+IFLDL IF(KTO(JFLD) == MYPROC) THEN ILENR(:)=ILENR(:)+IFLDL ENDIF ENDDO DO JROC=2,NPROC IOFFR(JROC)=IOFFR(JROC-1)+ ILENR(JROC-1) IOFFS(JROC)=IOFFS(JROC-1)+ ILENS(JROC-1) ENDDO IFLDS=0 DO JROC=1,NPROC IF(ILENS(JROC) > 0) THEN DO JFLD=1,KFGATHG IF(KTO(JFLD) == JROC) THEN DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+IFLDS*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO IFLDS=IFLDS+1 ENDIF ENDDO ENDIF ENDDO ENDIF IMYFIELDS = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX*IMYFIELDS*NPROC)) ELSE ALLOCATE(ZBUF(1)) ENDIF IFLDR = 0 CALL GSTATS_BARRIER(789) CALL GSTATS(809,0) IF( LLSAME )THEN !Send ISND = KTO(1) ITAG = MTAGDISTSP+1+17 CALL MPL_SEND(ZFLD,KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(1),& &CDSTRING='GATH_GRID_32_CTL:') ! RECIEVE IF(KTO(1) == MYPROC) THEN IFLDR = KFGATHG DO JROC=1,NPROC ITAG = MTAGDISTSP+1+17 IRCV = JROC IOFF=IFLDL*KFGATHG*(JROC-1) CALL MPL_RECV(ZBUF(IOFF+1:IOFF+IFLDL*KFGATHG),KSOURCE=NPRCIDS(IRCV),& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILRECV,& &KTAG=ITAG,CDSTRING='GATH_GRID_32_CTL:') ENDDO ENDIF CALL MPL_WAIT(KREQUEST=ISENDREQ(1), & & CDSTRING='GATH_GRID_32_CTL: WAIT') ELSE IFLDR=IMYFIELDS CALL MPL_ALLTOALLV(PSENDBUF=ZFLD,KSENDCOUNTS=ILENS,& & PRECVBUF=ZBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& & CDSTRING='GATH_GRID_32_CTL:') !!$ ITAG = MTAGDISTSP+1+17 !!$ DO JROC=1,NPROC !!$ ISND=JROC !!$ IOFF=IOFFS(JROC) !!$ ILEN=ILENS(JROC) !!$ IF(ILEN > 0 ) THEN !!$ CALL MPL_SEND(ZFLD(IOFF+1:IOFF+ILEN),KDEST=NPRCIDS(ISND),KTAG=ITAG,& !!$ &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISND),& !!$ &CDSTRING='GATH_GRID_32_CTL:') !!$ ENDIF !!$ ENDDO !!$ DO JROC=1,NPROC !!$ IRCV = JROC !!$ IOFF = IOFFR(JROC) !!$ ILEN = ILENR(JROC) !!$ IF(ILEN > 0 ) THEN !!$ CALL MPL_RECV(ZBUF(IOFF+1:IOFF+ILEN),KSOURCE=NPRCIDS(IRCV),& !!$ &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILRECV,& !!$ &KTAG=ITAG,CDSTRING='GATH_GRID_32_CTL:') !!$ ENDIF !!$ ENDDO !!$ DO JROC=1,NPROC !!$ ISND=JROC !!$ ILEN=ILENS(JROC) !!$ IF(ILEN > 0 ) THEN !!$ CALL MPL_WAIT(KREQUEST=ISENDREQ(JROC), & !!$ & CDSTRING='GATH_GRID_32_CTL: WAIT') !!$ ENDIF !!$ ENDDO ENDIF CALL GSTATS(809,1) CALL GSTATS_BARRIER2(789) CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JA,JB,IPROC,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILEN,ILOFF,JGL,JLON,JFLD) DO JFLD=1,IFLDR DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(IPROC,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) = & & ZBUF(ILEN+JLON+(JFLD-1)*IFLDL+(IPROC-1)*IFLDL*IMYFIELDS) ENDDO ILEN = ILEN + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ! Synhronize processors ! Should not be necessary !!$ CALL GSTATS(784,0) !!$ CALL MPL_BARRIER(CDSTRING='GATH_GRID_32_CTL:') !!$ CALL GSTATS(784,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID_32_CTL END MODULE GATH_GRID_32_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/dealloc_resol_mod.F900000664000175000017500000001325515174631767023641 0ustar alastairalastair! (C) Copyright 2013- ECMWF. ! (C) Copyright 2013- 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. ! MODULE DEALLOC_RESOL_MOD CONTAINS SUBROUTINE DEALLOC_RESOL(KRESOL) !**** *DEALLOC_RESOL* - Deallocations of a resolution ! Purpose. ! -------- ! Release allocated arrays for a given resolution !** Interface. ! ---------- ! CALL DEALLOC_RESOL ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 from trans_end ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM USE TPM_DIM ,ONLY : R USE TPM_GEN ,ONLY : LENABLED, NOUT,NDEF_RESOL USE TPM_DISTR ,ONLY : D,NPRTRV USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F USE TPM_FFTW ,ONLY : DESTROY_PLANS_FFTW USE TPM_FLT ,ONLY : S USE TPM_CTL ,ONLY : C USE SEEFMM_MIX ,ONLY : FREE_SEEFMM USE SET_RESOL_MOD ,ONLY : SET_RESOL ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) :: JMLOC,IPRTRV,JSETV,IMLOC,IM,ILA,ILS, JRESOL ! ------------------------------------------------------------------ IF (.NOT.LENABLED(KRESOL)) THEN WRITE(UNIT=NOUT,FMT='('' DEALLOC_RESOL WARNING : KRESOL = '',I3,'' ALREADY DISABLED '')') KRESOL ELSE CALL SET_RESOL(KRESOL) !TPM_FLT IF( ALLOCATED(S%FA) ) THEN DO JMLOC=1,D%NUMP,NPRTRV ! +++++++++++++++++++++ JMLOC LOOP ++++++++++ IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IF( S%LUSEFLT .AND. ILA > S%ITHRESHOLD) THEN ELSE IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMA)) DEALLOCATE(S%FA(IMLOC)%RPNMA) ENDIF IF( S%LUSEFLT .AND. ILS > S%ITHRESHOLD) THEN ELSE IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMS)) DEALLOCATE(S%FA(IMLOC)%RPNMS) ENDIF IF(S%LDLL) THEN IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMWI)) DEALLOCATE(S%FA(IMLOC)%RPNMWI) IF(.NOT.C%CIO_TYPE == 'mbuf' .AND. ASSOCIATED(S%FA(IMLOC)%RPNMWO)) DEALLOCATE(S%FA(IMLOC)%RPNMWO) ENDIF ENDDO ENDDO DEALLOCATE(S%FA) ENDIF IF(S%LDLL) THEN CALL FREE_SEEFMM(S%FMM_INTI) IF(ASSOCIATED(S%FMM_INTI)) DEALLOCATE(S%FMM_INTI) ENDIF !TPM_DISTR IF(ALLOCATED(D%NFRSTLAT)) DEALLOCATE(D%NFRSTLAT) IF(ALLOCATED(D%NLSTLAT)) DEALLOCATE(D%NLSTLAT) IF(ALLOCATED(D%NPTRLAT)) DEALLOCATE(D%NPTRLAT) IF(ALLOCATED(D%NPTRFRSTLAT)) DEALLOCATE(D%NPTRFRSTLAT) IF(ALLOCATED(D%NPTRLSTLAT)) DEALLOCATE(D%NPTRLSTLAT) IF(ALLOCATED(D%LSPLITLAT)) DEALLOCATE(D%LSPLITLAT) IF(ALLOCATED(D%NSTA)) DEALLOCATE(D%NSTA) IF(ALLOCATED(D%NONL)) DEALLOCATE(D%NONL) IF(ALLOCATED(D%NGPTOTL)) DEALLOCATE(D%NGPTOTL) IF(ALLOCATED(D%NPROCA_GP)) DEALLOCATE(D%NPROCA_GP) IF(D%LWEIGHTED_DISTR) THEN IF(ALLOCATED(D%RWEIGHT)) DEALLOCATE(D%RWEIGHT) ENDIF IF(ALLOCATED(D%MYMS)) DEALLOCATE(D%MYMS) IF(ALLOCATED(D%NUMPP)) DEALLOCATE(D%NUMPP) IF(ALLOCATED(D%NPOSSP)) DEALLOCATE(D%NPOSSP) IF(ALLOCATED(D%NPROCM)) DEALLOCATE(D%NPROCM) IF(ALLOCATED(D%NDIM0G)) DEALLOCATE(D%NDIM0G) IF(ALLOCATED(D%NASM0)) DEALLOCATE(D%NASM0) IF(ALLOCATED(D%NATM0)) DEALLOCATE(D%NATM0) IF(ALLOCATED(D%NLATLS)) DEALLOCATE(D%NLATLS) IF(ALLOCATED(D%NLATLE)) DEALLOCATE(D%NLATLE) IF(ALLOCATED(D%NPMT)) DEALLOCATE(D%NPMT) IF(ALLOCATED(D%NPMS)) DEALLOCATE(D%NPMS) IF(ALLOCATED(D%NPMG)) DEALLOCATE(D%NPMG) IF(ALLOCATED(D%NULTPP)) DEALLOCATE(D%NULTPP) IF(ALLOCATED(D%NPROCL)) DEALLOCATE(D%NPROCL) IF(ALLOCATED(D%NPTRLS)) DEALLOCATE(D%NPTRLS) IF(ALLOCATED(D%NALLMS)) DEALLOCATE(D%NALLMS) IF(ALLOCATED(D%NPTRMS)) DEALLOCATE(D%NPTRMS) IF(ALLOCATED(D%NSTAGT0B)) DEALLOCATE(D%NSTAGT0B) IF(ALLOCATED(D%NSTAGT1B)) DEALLOCATE(D%NSTAGT1B) IF(ALLOCATED(D%NPNTGTB0)) DEALLOCATE(D%NPNTGTB0) IF(ALLOCATED(D%NPNTGTB1)) DEALLOCATE(D%NPNTGTB1) IF(ALLOCATED(D%NLTSFTB)) DEALLOCATE(D%NLTSFTB) IF(ALLOCATED(D%NLTSGTB)) DEALLOCATE(D%NLTSGTB) IF(ALLOCATED(D%MSTABF)) DEALLOCATE(D%MSTABF) IF(ALLOCATED(D%NSTAGTF)) DEALLOCATE(D%NSTAGTF) !TPM_FFTW CALL DESTROY_PLANS_FFTW !TPM_FIELDS IF(ALLOCATED(F%RMU)) DEALLOCATE(F%RMU) IF(ALLOCATED(F%RW)) DEALLOCATE(F%RW) IF(ALLOCATED(F%R1MU2)) DEALLOCATE(F%R1MU2) IF(ALLOCATED(F%RACTHE)) DEALLOCATE(F%RACTHE) IF(ALLOCATED(F%REPSNM)) DEALLOCATE(F%REPSNM) IF(ALLOCATED(F%RN)) DEALLOCATE(F%RN) IF(ALLOCATED(F%RLAPIN)) DEALLOCATE(F%RLAPIN) IF(ALLOCATED(F%NLTN)) DEALLOCATE(F%NLTN) IF( S%LKEEPRPNM ) THEN IF(ALLOCATED(F%RPNM)) DEALLOCATE(F%RPNM) ENDIF IF( S%LDLL ) THEN IF(ALLOCATED(F%RMU2)) DEALLOCATE(F%RMU2) IF(ALLOCATED(F%RACTHE2)) DEALLOCATE(F%RACTHE2) ENDIF !TPM_GEOMETRY IF(ALLOCATED(G%NMEN)) DEALLOCATE(G%NMEN) IF(ALLOCATED(G%NDGLU)) DEALLOCATE(G%NDGLU) IF(ALLOCATED(G%NLOEN)) DEALLOCATE(G%NLOEN) LENABLED(KRESOL)=.FALSE. NDEF_RESOL = COUNT(LENABLED) ! Do not stay on a disabled resolution DO JRESOL=1,SIZE(LENABLED) IF (LENABLED(JRESOL)) THEN CALL SET_RESOL(JRESOL) EXIT ENDIF ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DEALLOC_RESOL END MODULE DEALLOC_RESOL_MOD ectrans-1.8.0/src/trans/cpu/internal/ltinv_mod.F900000664000175000017500000002277515174631767022175 0ustar alastairalastair! (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. ! MODULE LTINV_MOD CONTAINS SUBROUTINE LTINV(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_FIELDS ,ONLY : F USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B, LATLON USE TPM_FLT ,ONLY : S USE TPM_GEOMETRY ,ONLY : G !USE PRLE1_MOD USE PREPSNM_MOD ,ONLY : PREPSNM USE PRFI1B_MOD ,ONLY : PRFI1B USE VDTUV_MOD ,ONLY : VDTUV USE SPNSDE_MOD ,ONLY : SPNSDE USE LEINV_MOD ,ONLY : LEINV USE ASRE1B_MOD ,ONLY : ASRE1B USE FSPGL_INT_MOD ,ONLY : FSPGL_INT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE CDMAP_MOD ,ONLY : CDMAP !**** *LTINV* - Inverse Legendre transform ! ! Purpose. ! -------- ! Tranform from Laplace space to Fourier space, compute U and V ! and north/south derivatives of state variables. !** Interface. ! ---------- ! *CALL* *LTINV(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : The Laplace arrays of the model. ! -------------------- The values of the Legendre polynomials ! The grid point arrays of the model ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1B - prepares the spectral fields ! VDTUV - compute u and v from vorticity and divergence ! SPNSDE - compute north-south derivatives ! LEINV - Inverse Legendre transform ! ASRE1 - recombination of symmetric/antisymmetric part ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINV in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 INTEGER(KIND=JPIM), INTENT(IN) :: KDIM1 REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(IN) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB) :: ZACTHE REAL(KIND=JPRB) :: ZIA(R%NLEI1,KLEI2) REAL(KIND=JPRB) :: ZEPSNM(0:R%NTMAX+2) !REAL(KIND=JPRB) :: ZSOA1(KDIM1,R%NLEI3),ZAOA1(KDIM1,R%NLEI3) REAL(KIND=JPRB), ALLOCATABLE :: ZSOA1(:,:), ZAOA1(:,:), ZALN(:,:) INTEGER(KIND=JPIM) :: IFC, ISTA, IIFC, IDGLU, JGL, JFLD INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISLO,ISU,IDL,IDU, IGLS INTEGER(KIND=JPIM) :: IFIRST, ILAST, IDIM1,IDIM3,J3 INTEGER(KIND=JPIM) :: INSDS, INSDE, IUVS, IUVE, IST REAL(KIND=JPHOOK) :: ZHOOK_HANDLE !CHARACTER(LEN=10) :: CLHOOK ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- !WRITE(CLHOOK,FMT='(A,I4.4)') 'LTINV_',KM IF (LHOOK) CALL DR_HOOK('LTINV_MOD',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !* 1. PREPARE ZEPSNM. ! --------------- CALL PREPSNM(KM,KMLOC,ZEPSNM) ! ------------------------------------------------------------------ !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- IFIRST = 1 ILAST = 4*KF_UV IF (KF_UV > 0) THEN IVORL = 1 IVORU = 2*KF_UV IDIVL = 2*KF_UV+1 IDIVU = 4*KF_UV IUL = 4*KF_UV+1 IUU = 6*KF_UV IVL = 6*KF_UV+1 IVU = 8*KF_UV CALL PRFI1B(KM,ZIA(:,IVORL:IVORU),PSPVOR,KF_UV,KFLDPTRUV) CALL PRFI1B(KM,ZIA(:,IDIVL:IDIVU),PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV CALL VDTUV(KM,KF_UV,ZEPSNM,ZIA(:,IVORL:IVORU),ZIA(:,IDIVL:IDIVU),& & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU)) ENDIF IF(KF_SCALARS > 0)THEN IF(PRESENT(PSPSCALAR)) THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL PRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IFIRST = ILAST+1 ILAST = IFIRST-1+2*NF_SC2 CALL PRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC2(:,:),NF_SC2) ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL PRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC3A(:,:,J3),IDIM1) ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL PRFI1B(KM,ZIA(:,IFIRST:ILAST),PSPSC3B(:,:,J3),IDIM1) ENDDO ENDIF ENDIF IF(ILAST /= 8*KF_UV+2*KF_SCALARS) THEN WRITE(0,*) 'LTINV:KF_UV,KF_SCALARS,ILAST ',KF_UV,KF_SCALARS,ILAST CALL ABORT_TRANS('LTINV_MOD:ILAST /= 8*KF_UV+2*KF_SCALARS') ENDIF ENDIF IF (KF_SCDERS > 0) THEN ISL = 2*(4*KF_UV)+1 ISU = ISL+2*KF_SCALARS-1 IDL = 2*(4*KF_UV+KF_SCALARS)+1 IDU = IDL+2*KF_SCDERS-1 CALL SPNSDE(KM,KF_SCALARS,ZEPSNM,ZIA(:,ISL:ISU),ZIA(:,IDL:IDU)) ENDIF ! ------------------------------------------------------------------ !* 4. INVERSE LEGENDRE TRANSFORM. ! --------------------------- ISTA = 1 IFC = 2*KF_OUT_LT IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN ISTA = ISTA+2*KF_UV ENDIF IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN ISTA = ISTA+2*KF_UV ENDIF IIFC=IFC IF(KM == 0)THEN IIFC=IFC/2 ENDIF IF( LATLON.AND.S%LDLL ) THEN IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) IF( (S%LSHIFTLL .AND. KM < 2*IDGLU) .OR.& & (.NOT.S%LSHIFTLL .AND. KM < 2*(IDGLU-1)) ) THEN ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) ISLO = S%FA(KMLOC)%ISLD ALLOCATE(ZAOA1(KDIM1,R%NLEI3)) ALLOCATE(ZSOA1(KDIM1,R%NLEI3)) CALL LEINV(KM,KMLOC,IFC,IIFC,KF_OUT_LT,ISL,IDGLU,ZIA(:,ISTA:ISTA+IFC-1),ZAOA1,ZSOA1) !* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. ! before (non-linear) mapping !!!! ALLOCATE( ZALN(KDIM1,2*R%NDGNH) ) DO JGL=ISL, R%NDGNH IGLS = 2*R%NDGNH+1-JGL DO JFLD=1,2*KF_OUT_LT ZALN(JFLD, JGL) = ZSOA1(JFLD,JGL)+ZAOA1(JFLD,JGL) ZALN(JFLD, IGLS) = ZSOA1(JFLD,JGL)-ZAOA1(JFLD,JGL) ENDDO ENDDO IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN IST = 1 IF(LVORGP) THEN IST = IST+2*KF_UV ENDIF IF(LDIVGP) THEN IST = IST+2*KF_UV ENDIF IUVS = IST IUVE = IST+4*KF_UV-1 IST = IST+4*KF_UV IST = IST+2*KF_SCALARS INSDS = IST INSDE = IST+2*KF_SCDERS-1 IST = IST+2*KF_SCDERS IGLS = 2*R%NDGNH - ISL + 1 IF( KF_UV > 0 ) THEN DO JGL=ISL, IGLS ZACTHE = REAL(F%RACTHE(JGL),JPRB) DO JFLD=IUVS,IUVE ZALN(JFLD, JGL) = ZALN(JFLD,JGL)*ZACTHE ENDDO ENDDO ENDIF IF( KF_SCDERS > 0 ) THEN DO JGL=ISL, IGLS ZACTHE = REAL(F%RACTHE(JGL),JPRB) DO JFLD=INSDS,INSDE ZALN(JFLD, JGL) = ZALN(JFLD,JGL)*ZACTHE ENDDO ENDDO ENDIF ENDIF DEALLOCATE(ZAOA1) DEALLOCATE(ZSOA1) ! this routine maps to the output latitudes AND fills the FOUBUF CALL CDMAP(KM,KMLOC,ISL,ISLO,ZEPSNM(R%NTMAX+1),-1_JPIM,& & R%NDGNH,S%NDGNHD,2*KF_OUT_LT,ZALN,ZALN) DEALLOCATE(ZALN) ENDIF ELSE IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) ALLOCATE(ZAOA1(KDIM1,R%NLEI3)) ALLOCATE(ZSOA1(KDIM1,R%NLEI3)) CALL LEINV(KM,KMLOC,IFC,IIFC,KF_OUT_LT,ISL,IDGLU,ZIA(:,ISTA:ISTA+IFC-1),ZAOA1,ZSOA1) ! ------------------------------------------------------------------ !* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART/FILL FOUBUF ! -------------------------------------------- CALL ASRE1B(KF_OUT_LT,KM,KMLOC,ZAOA1,ZSOA1) DEALLOCATE(ZAOA1) DEALLOCATE(ZSOA1) ENDIF ! ------------------------------------------------------------------ ! 6. OPTIONAL COMPUTATIONS IN FOURIER SPACE IF(PRESENT(FSPGL_PROC)) THEN CALL FSPGL_INT(KM,KMLOC,KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT,FSPGL_PROC,& & KFLDPTRUV,KFLDPTRSC) ENDIF IF (LHOOK) CALL DR_HOOK('LTINV_MOD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE LTINV END MODULE LTINV_MOD ectrans-1.8.0/src/trans/cpu/internal/tpm_flt.F900000664000175000017500000000411215174631767021630 0ustar alastairalastair! (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. ! MODULE TPM_FLT USE PARKIND1 ,ONLY: JPIM ,JPRB, JPRD USE BUTTERFLY_ALG_MOD ,ONLY: BUTTERFLY_STRUCT USE SEEFMM_MIX ,ONLY: FMM_TYPE IMPLICIT NONE SAVE TYPE FLT_TYPE INTEGER(KIND=JPIM) :: NSPOLEGL INTEGER(KIND=JPIM) :: NDGNH INTEGER(KIND=JPIM) :: INS2 INTEGER(KIND=JPIM) :: INA2 REAL(KIND=JPRB) ,POINTER :: RPNMS(:,:) ! Legendre polynomials REAL(KIND=JPRB) ,POINTER :: RPNMA(:,:) ! Legendre polynomials REAL(KIND=JPRD) ,POINTER :: RPNMDS(:,:) ! Legendre polynomials REAL(KIND=JPRD) ,POINTER :: RPNMDA(:,:) ! Legendre polynomials REAL(KIND=JPRB) :: RCS REAL(KIND=JPRB) :: RCA !REAL(KIND=JPRB) ,POINTER :: RPNMCDO(:,:) ! Legendre polynomials for C-D formula at orig roots !REAL(KIND=JPRB) ,POINTER :: RPNMCDD(:,:) ! Legendre polynomials for C-D formula at dual roots REAL(KIND=JPRB) ,POINTER :: RPNMWI(:,:) ! special weights REAL(KIND=JPRB) ,POINTER :: RPNMWO(:,:) ! special weights INTEGER(KIND=JPIM) :: ISLD ! starting latitude dual ! Butterfly TYPE(BUTTERFLY_STRUCT) :: YBUT_STRUCT_S,YBUT_STRUCT_A END TYPE FLT_TYPE TYPE FLT_TYPE_WRAP TYPE(FLT_TYPE),ALLOCATABLE :: FA(:) LOGICAL :: LDLL LOGICAL :: LSHIFTLL LOGICAL :: LUSEFLT LOGICAL :: LUSE_BELUSOV LOGICAL :: LKEEPRPNM LOGICAL :: LSOUTHPNM ! .TRUE. to compute Legendre polynomials on southern hemisphere INTEGER(KIND=JPIM) :: IMLOC INTEGER(KIND=JPIM) :: ITHRESHOLD INTEGER(KIND=JPIM) :: NDGNHD ! dual set dimension INTEGER(KIND=JPIM) :: NDLON ! dual number of longitudes INTEGER(KIND=JPIM) :: NDGL ! dual number of latitudes TYPE(FMM_TYPE),POINTER :: FMM_INTI ! FMM interpolation END TYPE FLT_TYPE_WRAP TYPE(FLT_TYPE_WRAP),ALLOCATABLE,TARGET :: FLT_RESOL(:) TYPE(FLT_TYPE_WRAP),POINTER :: S END MODULE TPM_FLT ectrans-1.8.0/src/trans/cpu/internal/ftdir_ctlad_mod.F900000664000175000017500000001237215174631767023310 0ustar alastairalastair! (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. ! MODULE FTDIR_CTLAD_MOD CONTAINS SUBROUTINE FTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & & KVSETUV,KVSETSC,KPTRGP,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *FTDIR_CTLAD - Direct Fourier transform control - adjoint ! Purpose. Control routine for Grid-point to Fourier transform ! -------- !** Interface. ! ---------- ! CALL FTDIR_CTLAD(..) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! PGP - gridpoint array ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fields in gridpoint space ! Method. ! ------- ! Externals. TRGTOL - transposition routine ! ---------- FOURIER_OUT - copy fourier data to Fourier buffer ! FTDIR - fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE TRLTOG_MOD ,ONLY : TRLTOG USE FOURIER_OUTAD_MOD ,ONLY : FOURIER_OUTAD USE FTDIRAD_MOD ,ONLY : FTDIRAD ! IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS 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) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL , INTENT(OUT) :: PGP2(:,:,:) ! Local variables REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER :: ZGTF(:,:) INTEGER(KIND=JPIM) :: IST INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: JGL,IGL INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 ! ------------------------------------------------------------------ ! Field distribution in Spectral/Fourier space CALL GSTATS(133,0) IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ! Now, force the OS to allocate this shared array right now, not when it starts ! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN ZGTF_HEAP(1,1)=HUGE(1._JPRB) ENDIF ZGTF => ZGTF_HEAP(:,:) ENDIF CALL GSTATS(1642, 0) ! If this rank has any Fourier fields, Fourier transform them IF (KF_FS > 0) THEN ! Loop over latitudes !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL) DO JGL = 1, D%NDGL_FS ! Copy out Fourier data from FOUBUF_IN CALL FOURIER_OUTAD(ZGTF, KF_FS, JGL) ! Fourier transform CALL FTDIRAD(ZGTF, KF_FS, JGL) ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1642, 1) CALL GSTATS(133,1) ! Transposition CALL GSTATS(183,0) IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:) = -1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) DO J3=1,UBOUND(PGP3A,3) IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) DO J3=1,UBOUND(PGP3B,3) IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& &PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(183,1) ! ------------------------------------------------------------------ END SUBROUTINE FTDIR_CTLAD END MODULE FTDIR_CTLAD_MOD ectrans-1.8.0/src/trans/cpu/internal/updspb_mod.F900000664000175000017500000000746415174631767022334 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- 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. ! MODULE UPDSPB_MOD CONTAINS SUBROUTINE UPDSPB(KM,KFIELD,POA,PSPEC,KFLDPTR) !**** *UPDSPB* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update spectral arrays for a fixed zonal wave-number ! from values in POA. !** Interface. ! ---------- ! CALL UPDSPB(....) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFIELD - number of fields ! POA - work array ! PSPEC - spectral array ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the ! first and last field ! L. Isaksen : 95-06-06 Reordering of spectral arrays ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELD REAL(KIND=JPRB) ,INTENT(IN) :: POA(:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN, ISMAX, ITMAX, IASM0,IFLD ! ------------------------------------------------------------------ !* 0. NOTE. ! ----- ! The following transfer reads : ! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) ! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) ! with n from m to NSMAX ! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. ! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) ! nn is the loop index. !* 1. UPDATE SPECTRAL FIELDS. ! ----------------------- ISMAX = R%NSMAX ITMAX = R%NTMAX IASM0 = D%NASM0(KM) !* 1.1 KM=0 IF(KM == 0) THEN IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELD IR = 2*JFLD-1 IFLD = KFLDPTR(JFLD) DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+(ITMAX+2-JN)*2 PSPEC(IFLD,INM) = POA(JN,IR) PSPEC(IFLD,INM+1) = 0.0_JPRB ENDDO ENDDO ELSE DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+(ITMAX+2-JN)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELD IR = 2*JFLD-1 PSPEC(JFLD,INM) = POA(JN,IR) PSPEC(JFLD,INM+1) = 0.0_JPRB ENDDO ENDDO ENDIF !* 1.2 KM!=0 ELSE IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELD IR = 2*JFLD-1 II = IR+1 IFLD = KFLDPTR(JFLD) DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+((ITMAX+2-JN)-KM)*2 PSPEC(IFLD,INM) = POA(JN,IR) PSPEC(IFLD,INM+1) = POA(JN,II) ENDDO ENDDO ELSE DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+((ITMAX+2-JN)-KM)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELD IR = 2*JFLD-1 II = IR+1 PSPEC(JFLD,INM) = POA(JN,IR) PSPEC(JFLD,INM+1) = POA(JN,II) ENDDO ENDDO ENDIF ENDIF ! ------------------------------------------------------------------ END SUBROUTINE UPDSPB END MODULE UPDSPB_MOD ectrans-1.8.0/src/trans/cpu/internal/dir_trans_ctlad_mod.F900000664000175000017500000001560415174631767024166 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE DIR_TRANS_CTLAD_MOD CONTAINS SUBROUTINE DIR_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANS_CTLAD* - Control routine for direct spectral transform-adj. ! Purpose. ! -------- ! Control routine for the direct spectral transform !** Interface. ! ---------- ! CALL DIR_TRANS_CTLAD(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity ! PSPDIV(:,:) - spectral divergence ! PSPSCALAR(:,:) - spectral scalarvalued fields ! 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. ! PGP(:,:,:) - gridpoint fields ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTDIR_CTLAD - control of Legendre transform ! FTDIR_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NPROMATR USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE LTDIR_CTLAD_MOD ,ONLY : LTDIR_CTLAD USE FTDIR_CTLAD_MOD ,ONLY : FTDIR_CTLAD ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) 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(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGP2(:,:,:) ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_GPB ! ------------------------------------------------------------------ ! Perform transform IF_GPB = 2*KF_UV_G+KF_SCALARS_G IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& & KVSETUV,KVSETSC) IBLKS=(IF_GPB-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G DO JFLD=1,IF_UV_G IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDDO DO JFLD=1,IF_SCALARS_G IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO CALL LTDIR_CTLAD(IF_FS,IF_UV,IF_SCALARS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC) IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL FTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL FTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KPTRGP=IPTRGP,PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL FTDIR_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) ENDIF ENDDO ELSE ! No splitting of fields, transform done in one go CALL LTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & &PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& &PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2) CALL FTDIR_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIR_TRANS_CTLAD END MODULE DIR_TRANS_CTLAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ltdir_ctlad_mod.F900000664000175000017500000000601315174631767023311 0ustar alastairalastair! (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. ! MODULE LTDIR_CTLAD_MOD CONTAINS SUBROUTINE LTDIR_CTLAD(KF_FS,KF_UV,KF_SCALARS, & & PSPVOR,PSPDIV,PSPSCALAR, & & PSPSC3A,PSPSC3B,PSPSC2, & & KFLDPTRUV,KFLDPTRSC) !**** *LTDIR_CTLAD* - Control routine for direct Legendre transform ! Purpose. ! -------- ! Direct Legendre transform !** Interface. ! ---------- ! CALL LTDIR_CTLAD(...) ! Explicit arguments : ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : LALLOPERM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE LTDIRAD_MOD ,ONLY : LTDIRAD USE TRMTOL_MOD ,ONLY : TRMTOL ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2 ! ------------------------------------------------------------------ ! Transposition from Fourier space distribution to spectral space distribution CALL GSTATS(105,0) IBLEN = D%NLENGT0B*2*KF_FS IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) ENDIF IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF ! Direct Legendre transform ILED2 = 2*KF_FS CALL GSTATS(1646,0) IF(KF_FS > 0) THEN !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL LTDIRAD(IM,JM,KF_FS,KF_UV,KF_SCALARS,ILED2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1646,1) CALL GSTATS(105,1) CALL GSTATS(181,0) CALL TRMTOL(FOUBUF,FOUBUF_IN,2*KF_FS) CALL GSTATS(181,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) ! ------------------------------------------------------------------ END SUBROUTINE LTDIR_CTLAD END MODULE LTDIR_CTLAD_MOD ectrans-1.8.0/src/trans/cpu/internal/updspbad_mod.F900000664000175000017500000000774215174631767022640 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- 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. ! MODULE UPDSPBAD_MOD CONTAINS SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) !**** *UPDSPBAD* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update spectral arrays for a fixed zonal wave-number ! from values in POA. !** Interface. ! ---------- ! CALL UPDSPBAD(....) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFIELD - number of fields ! POA - work array ! PSPEC - spectral array ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! D. Giard : 93-03-19 truncations NSMAX and NTMAX (see NOTE) ! R. El Khatib : 94-08-02 Replace number of fields by indexes of the ! first and last field ! L. Isaksen : 95-06-06 Reordering of spectral arrays ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELD REAL(KIND=JPRB) ,INTENT(OUT) :: POA(:,:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, INM, IR, JFLD, JN, ISMAX, ITMAX, IASM0,IFLD ! ------------------------------------------------------------------ !* 0. NOTE. ! ----- ! The following transfer reads : ! SPEC(k,NASM0(m)+NLTN(n)*2) =POA(nn,2*k-1) (real part) ! SPEC(k,NASM0(m)+NLTN(n)*2+1)=POA(nn,2*k ) (imaginary part) ! with n from m to NSMAX ! and nn=NTMAX+2-n from NTMAX+2-m to NTMAX+2-NSMAX. ! NLTN(m)=NTMAX+2-m : n=NLTN(nn),nn=NLTN(n) ! nn is the loop index. !* 1. UPDATE SPECTRAL FIELDS. ! ----------------------- ISMAX = R%NSMAX ITMAX = R%NTMAX IASM0 = D%NASM0(KM) POA(:,:) = 0.0_JPRB !* 1.1 KM=0 IF(KM == 0) THEN IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELD IR = 2*JFLD-1 IFLD = KFLDPTR(JFLD) DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+(ITMAX+2-JN)*2 POA(JN,IR) = PSPEC(IFLD,INM) PSPEC(IFLD,INM) = 0.0_JPRB ENDDO ENDDO ELSE DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+(ITMAX+2-JN)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELD IR = 2*JFLD-1 POA(JN,IR) = PSPEC(JFLD,INM) PSPEC(JFLD,INM) = 0.0_JPRB ENDDO ENDDO ENDIF !* 1.2 KM!=0 ELSE IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELD IR = 2*JFLD-1 II = IR+1 IFLD = KFLDPTR(JFLD) DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+((ITMAX+2-JN)-KM)*2 POA(JN,IR) = PSPEC(IFLD,INM) POA(JN,II) = PSPEC(IFLD,INM+1) PSPEC(IFLD,INM) = 0.0_JPRB PSPEC(IFLD,INM+1) = 0.0_JPRB ENDDO ENDDO ELSE DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+((ITMAX+2-JN)-KM)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELD IR = 2*JFLD-1 II = IR+1 POA(JN,IR) = PSPEC(JFLD,INM) POA(JN,II) = PSPEC(JFLD,INM+1) PSPEC(JFLD,INM) = 0.0_JPRB PSPEC(JFLD,INM+1) = 0.0_JPRB ENDDO ENDDO ENDIF ENDIF ! ------------------------------------------------------------------ END SUBROUTINE UPDSPBAD END MODULE UPDSPBAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ltdir_mod.F900000664000175000017500000001361615174631767022151 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE LTDIR_MOD CONTAINS SUBROUTINE LTDIR(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F USE TPM_TRANS, ONLY : LATLON USE TPM_FLT ,ONLY : S USE TPM_GEOMETRY ,ONLY : G USE PREPSNM_MOD ,ONLY : PREPSNM USE PRFI2_MOD ,ONLY : PRFI2 USE LDFOU2_MOD ,ONLY : LDFOU2 USE LEDIR_MOD ,ONLY : LEDIR USE UVTVD_MOD ,ONLY : UVTVD USE UPDSP_MOD ,ONLY : UPDSP USE CDMAP_MOD , ONLY : CDMAP !**** *LTDIR* - Control of Direct Legendre transform step ! Purpose. ! -------- ! Tranform from Fourier space to spectral space, compute ! vorticity and divergence. !** Interface. ! ---------- ! *CALL* *LTDIR(...)* ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI2 - prepares the Fourier work arrays for model variables. ! LDFOU2 - computations in Fourier space ! LEDIR - direct Legendre transform ! UVTVD - ! UPDSP - updating of spectral arrays (fields) ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-24 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified 94-04-06 R. El khatib Full-POS implementation ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group : 95-10-01 Support for Distributed Memory version ! K. YESSAD (AUGUST 1996): ! - Legendre transforms for transmission coefficients. ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! R. El Khatib 12-Jul-2012 LDSPC2 replaced by UVTVD ! ------------------------------------------------------------------ IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 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) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IFC, IIFC, IDGLU INTEGER(KIND=JPIM) :: IUS, IUE, IVS, IVE, IVORS, IVORE, IDIVS, IDIVE INTEGER(KIND=JPIM) :: ISL, ISLO ! LOCAL REALS !REAL(KIND=JPRB) :: ZSIA(KLED2,R%NDGNH), ZAIA(KLED2,R%NDGNH) REAL(KIND=JPRB) :: ZEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB) :: ZOA1(R%NLED4,KLED2), ZOA2(R%NLED4,MAX(4*KF_UV,1)) REAL(KIND=JPRB), ALLOCATABLE :: ZAIA(:,:), ZSIA(:,:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !* 4. DIRECT LEGENDRE TRANSFORM. ! -------------------------- IFC = 2*KF_FS IIFC = IFC IF(KM == 0)THEN IIFC = IFC/2 ENDIF IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) ALLOCATE(ZSIA(KLED2,R%NDGNH)) ALLOCATE(ZAIA(KLED2,R%NDGNH)) IF( LATLON.AND.S%LDLL ) THEN IF( (S%LSHIFTLL .AND. KM < 2*IDGLU) .OR.& & (.NOT.S%LSHIFTLL .AND. KM < 2*(IDGLU-1)) ) THEN CALL PREPSNM(KM,KMLOC,ZEPSNM) ISLO = S%FA(KMLOC)%ISLD ! map from external to internal (gg) roots and split into anti-symmetric / symmetric CALL CDMAP(KM,KMLOC,ISL,ISLO,ZEPSNM(R%NTMAX+1),1_JPIM,& & R%NDGNH,S%NDGNHD,IFC,ZAIA,ZSIA) ENDIF ELSE CALL PRFI2(KM,KMLOC,KF_FS,ZAIA,ZSIA) ENDIF CALL LDFOU2(KM,KF_UV,ZAIA,ZSIA) CALL LEDIR(KM,KMLOC,IFC,IIFC,ISL,IDGLU,KLED2,ZAIA,ZSIA,ZOA1,F%RW(1:R%NDGNH)) DEALLOCATE(ZAIA) DEALLOCATE(ZSIA) ! ------------------------------------------------------------------ !* 5. COMPUTE VORTICITY AND DIVERGENCE. ! --------------------------------- IF( KF_UV > 0 ) THEN CALL PREPSNM(KM,KMLOC,ZEPSNM) IUS = 1 IUE = 2*KF_UV IVS = 2*KF_UV+1 IVE = 4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV CALL UVTVD(KM,KF_UV,ZEPSNM,ZOA1(:,IUS:IUE),ZOA1(:,IVS:IVE),& & ZOA2(:,IVORS:IVORE),ZOA2(:,IDIVS:IDIVE)) ENDIF ! ------------------------------------------------------------------ !* 6. UPDATE SPECTRAL ARRAYS. ! ----------------------- CALL UPDSP(KM,KF_UV,KF_SCALARS,ZOA1,ZOA2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('LTDIR_MOD',1,ZHOOK_HANDLE) END SUBROUTINE LTDIR END MODULE LTDIR_MOD ectrans-1.8.0/src/trans/cpu/internal/ftinv_ctlad_mod.F900000664000175000017500000002052715174631767023327 0ustar alastairalastair! (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. ! MODULE FTINV_CTLAD_MOD CONTAINS SUBROUTINE FTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *FTINV_CTLAD - Inverse Fourier transform control - adjoint ! Purpose. Control routine for Fourier to Gridpoint transform ! -------- !** Interface. ! ---------- ! CALL FTINV_CTLAD(..) ! Explicit arguments : ! -------------------- ! PGP - gridpoint array ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fi3elds in gridpoint space ! Method. ! ------- ! Externals. TRLTOG - transposition routine ! ---------- FOURIER_IN - copy fourier data from Fourier buffer ! FTINV - fourier transform ! FSC - Fourier space computations ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR USE TPM_TRANS ,ONLY : FOUBUF, LDIVGP, LSCDERS, LUVDER, LVORGP USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE FOURIER_INAD_MOD ,ONLY : FOURIER_INAD USE FSCAD_MOD ,ONLY : FSCAD USE FTINVAD_MOD ,ONLY : FTINVAD USE TRGTOL_MOD ,ONLY : TRGTOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT 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) :: KPTRGP(:) 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(:,:,:) ! ------------------------------------------------------------------ REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER :: ZGTF(:,:) REAL(KIND=JPRB),TARGET :: ZDUM(1,D%NLENGTF) REAL(KIND=JPRB),POINTER :: ZUV(:,:) REAL(KIND=JPRB),POINTER :: ZSCALAR(:,:) REAL(KIND=JPRB),POINTER :: ZNSDERS(:,:) REAL(KIND=JPRB),POINTER :: ZEWDERS(:,:) REAL(KIND=JPRB),POINTER :: ZUVDERS(:,:) INTEGER(KIND=JPIM) :: IST,IBLEN INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR ! ------------------------------------------------------------------ ! 4. Transposition IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:)=-1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) IGP3APAR=UBOUND(PGP3A,3) IF(LSCDERS) IGP3APAR=IGP3APAR/3 DO J3=1,IGP3APAR IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) IGP3BPAR=UBOUND(PGP3B,3) IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 DO J3=1,IGP3BPAR IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF IF(IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN WRITE(NERR,*)'FTINV_CTLAD:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G CALL ABORT_TRANS('FTINV_CTLAD_MOD:IOFF /= KF_SCALARS_G') ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IF( LVORGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF( LDIVGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G IF(LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF IF(KF_UV_G > 0 .AND. LUVDER) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IF(LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ! Now, force the OS to allocate this shared array right now, not when it starts ! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN ZGTF_HEAP(1,1)=HUGE(1._JPRB) ENDIF ZGTF => ZGTF_HEAP(:,:) ENDIF CALL GSTATS(182,0) CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& &PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(182,1) ! 3. Fourier transform IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN IST = 1 IF(LVORGP) THEN IST = IST+KF_UV ENDIF IF(LDIVGP) THEN IST = IST+KF_UV ENDIF IF(KF_UV>0) THEN ZUV => ZGTF(IST:IST+2*KF_UV-1,:) ELSE ZUV => ZDUM(1:1,:) ENDIF IST = IST+2*KF_UV IF(KF_SCALARS>0) THEN ZSCALAR => ZGTF(IST:IST+KF_SCALARS-1,:) ELSE ZSCALAR => ZDUM(1:1,:) ENDIF IST = IST+KF_SCALARS IF(KF_SCDERS>0) THEN ZNSDERS => ZGTF(IST:IST+KF_SCDERS-1,:) ELSE ZNSDERS => ZDUM(1:1,:) ENDIF IST = IST+KF_SCDERS IF(LUVDER) THEN ZUVDERS => ZGTF(IST:IST+2*KF_UV-1,:) IST = IST+2*KF_UV ELSE ZUVDERS => ZDUM(1:1,:) ENDIF IF(KF_SCDERS > 0) THEN ZEWDERS => ZGTF(IST:IST+KF_SCDERS-1,:) ELSE ZEWDERS => ZDUM(1:1,:) ENDIF ENDIF IBLEN = D%NLENGT0B*2*KF_OUT_LT IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF CALL GSTATS(132,0) CALL GSTATS(1641,0) ! Loop over latitudes !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) DO JGL = 1, D%NDGL_FS IGL = JGL IF(KF_FS > 0) THEN CALL FTINVAD(ZGTF,KF_FS,IGL) ENDIF ! 2. Fourier space computations IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN CALL FSCAD(IGL,KF_UV,KF_SCALARS,KF_SCDERS,& & ZUV,ZSCALAR,ZNSDERS,ZEWDERS,ZUVDERS) ENDIF ! 1. Copy Fourier data to local array CALL FOURIER_INAD(ZGTF,KF_OUT_LT,IGL) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1641,1) IF(KF_UV > 0 .OR. KF_SCDERS > 0) THEN NULLIFY(ZUV) NULLIFY(ZSCALAR) NULLIFY(ZNSDERS) NULLIFY(ZUVDERS) NULLIFY(ZEWDERS) ENDIF CALL GSTATS(132,1) ! ------------------------------------------------------------------ END SUBROUTINE FTINV_CTLAD END MODULE FTINV_CTLAD_MOD ectrans-1.8.0/src/trans/cpu/internal/dir_trans_ctl_mod.F900000664000175000017500000001547315174631767023665 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE DIR_TRANS_CTL_MOD CONTAINS SUBROUTINE DIR_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_UV,KF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANS_CTL* - Control routine for direct spectral transform. ! Purpose. ! -------- ! Control routine for the direct spectral transform !** Interface. ! ---------- ! CALL DIR_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity ! PSPDIV(:,:) - spectral divergence ! PSPSCALAR(:,:) - spectral scalarvalued fields ! 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. ! PGP(:,:,:) - gridpoint fields ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NPROMATR !USE TPM_TRANS !USE TPM_DISTR USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE LTDIR_CTL_MOD ,ONLY : LTDIR_CTL USE FTDIR_CTL_MOD ,ONLY : FTDIR_CTL ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS 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(:,:) 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(:) 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(:,:,:) ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV ! ------------------------------------------------------------------ ! Perform transform IF(NPROMATR > 0 .AND. KF_GP > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& & KVSETUV,KVSETSC) IBLKS=(KF_GP-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,KF_GP,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G DO JFLD=1,IF_UV_G IPTRGP(JFLD) = ISHFUV_G(ISTUV_G+JFLD-1) IPTRGP(JFLD+IF_UV_G) = KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDDO DO JFLD=1,IF_SCALARS_G IPTRGP(JFLD+2*IF_UV_G) = 2*KF_UV_G+ISHFSC_G(ISTSC_G+JFLD-1) ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL FTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL FTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KPTRGP=IPTRGP,PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL FTDIR_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,PGP=PGP) ENDIF CALL LTDIR_CTL(IF_FS,IF_UV,IF_SCALARS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC) ENDDO ELSE ! No splitting of fields, transform done in one go CALL FTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) CALL LTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & &PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& &PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIR_TRANS_CTL END MODULE DIR_TRANS_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/gpnorm_trans_ctltl_mod.F900000664000175000017500000002055415174631767024745 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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. ! MODULE GPNORM_TRANS_CTLTL_MOD CONTAINS SUBROUTINE GPNORM_TRANS_CTLTL(PGP,KFIELDS,KPROMA,PAVE,PW) !**** *GPNORM_TRANS_CTL* - calculate grid-point norms ! simplified version to be projected to adjoint ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL GPNORM_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! is uniquely false ! ! Author. ! ------- ! F. Vana after gpnorm_trans_ctl_mod ! Modifications. ! -------------- ! Original : September 2024 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD !ifndef INTERFACE USE TPM_GEN ,ONLY : NOUT USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LGPNORM, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRV, NPRTRW, MYSETV, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TRGTOL_MOD ,ONLY : TRGTOL USE SET2PE_MOD ,ONLY : SET2PE USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, JP_BLOCKING_STANDARD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA REAL(KIND=JPRD) ,INTENT(IN) :: PW(R%NDGL) !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IUBOUND(4) INTEGER(KIND=JPIM) :: IVSET(KFIELDS) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZGTF(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVEG(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZSND(:) REAL(KIND=JPRD),ALLOCATABLE :: ZRCV(:) INTEGER(KIND=JPIM) :: J,JGL,IGL,JL,JF,IF_GP,IF_SCALARS_G,IF_FS,JSETV,JSETW,IWLATS INTEGER(KIND=JPIM) :: IPROC,ITAG,ILEN,ILENR,IBEG,IEND,IND ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTLTL',0,ZHOOK_HANDLE) ! Set defaults NPROMA = KPROMA NGPBLKS = (D%NGPTOT-1)/NPROMA+1 ! Consistency checks IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLTL:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('GPNORM_TRANS_CTLTL:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFIELDS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLTL:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFIELDS CALL ABORT_TRANS('GPNORM_TRANS_CTLTL:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLTL:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('GPNORM_TRANS_CTLTL:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF_GP=KFIELDS IF_SCALARS_G=0 IF_FS=0 DO J=1,KFIELDS IVSET(J)=MOD(J-1,NPRTRV)+1 IF(IVSET(J)==MYSETV)THEN IF_FS=IF_FS+1 ENDIF ENDDO ALLOCATE(IVSETS(NPRTRV)) IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 ENDDO ALLOCATE(IVSETG(NPRTRV,MAXVAL(IVSETS(:)))) IVSETG(:,:)=0 IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 IVSETG(IVSET(J),IVSETS(IVSET(J)))=J ENDDO ALLOCATE(ZGTF(IF_FS,D%NLENGTF)) IF (SIZE(ZGTF) > 0) ZGTF(:,:)=0._JPRB ! force allocation right here, not inside an omp region below LGPNORM=.TRUE. CALL TRGTOL(ZGTF,IF_FS,IF_GP,IF_SCALARS_G,IVSET,PGP=PGP) LGPNORM=.FALSE. IBEG=1 IEND=D%NDGL_FS ALLOCATE(ZAVE(IF_FS,IBEG:IEND)) IF( IF_FS > 0 )THEN ZAVE(:,:)=0.0_JPRB ! FIRST DO SUMS IN EACH FULL LATITUDE CALL GSTATS(1429,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JGL,IGL,JF,JL) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 !CDIR NOLOOPCHG DO JF=1,IF_FS !DIR$ NEXTSCALAR DO JL=1,G%NLOEN(IGL) ZAVE(JF,JGL)=ZAVE(JF,JGL)+ZGTF(JF,D%NSTAGTF(JGL)+JL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1429,1) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=ZAVE(JF,JGL)*REAL(PW(IGL),JPRB)/G%NLOEN(IGL) ENDDO ENDDO ENDIF ! IT IS IMPORTANT THAT SUMS ARE NOW DONE IN LATITUDE ORDER ALLOCATE(ZAVEG(R%NDGL,KFIELDS)) ZAVEG(:,:)=0.0_JPRB DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 ZAVEG(IGL,IVSETG(MYSETV,JF))=ZAVEG(IGL,IVSETG(MYSETV,JF))+ZAVE(JF,JGL) ENDDO ENDDO ! RECEIVE ABOVE FROM OTHER NPRTRV SETS FOR SAME LATS BUT DIFFERENT FIELDS ITAG=123 CALL GSTATS(815,0) IF( MYSETV==1 )THEN DO JSETV=2,NPRTRV ILEN=(D%NDGL_FS)*IVSETS(JSETV) IF(ILEN > 0)THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,MYSETW,JSETV) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS_CTLTL:V') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTLTL:ILENR /= ILEN') ENDIF IND=0 DO JF=1,IVSETS(JSETV) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,IVSETG(JSETV,JF))=ZRCV(IND) ENDDO ENDDO DEALLOCATE(ZRCV) ENDIF ENDDO ELSE ILEN=(D%NDGL_FS)*IVSETS(MYSETV) IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,MYSETW,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,IVSETG(MYSETV,JF)) ENDDO ENDDO CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTLTL:V') DEALLOCATE(ZSND) ENDIF ENDIF ! FINALLY RECEIVE CONTRIBUTIONS FROM OTHER NPRTRW SETS IF( MYSETV == 1 )THEN IF( MYSETW == 1 )THEN DO JSETW=2,NPRTRW IWLATS=D%NULTPP(JSETW) ILEN=IWLATS*KFIELDS IF(ILEN > 0 )THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,JSETW,1) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS_CTLTL:W') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTLTL:ILENR /= ILEN') ENDIF IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(JSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,JF)=ZRCV(IND) ENDDO ENDDO DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IWLATS=D%NULTPP(MYSETW) ILEN=IWLATS*KFIELDS IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,1,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,JF) ENDDO ENDDO CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTLTL:W') DEALLOCATE(ZSND) ENDIF ENDIF ENDIF CALL GSTATS(815,1) IF( MYSETW == 1 .AND. MYSETV == 1 )THEN PAVE(:)=0.0_JPRB DO JGL=1,R%NDGL PAVE(:)=PAVE(:)+ZAVEG(JGL,:) ENDDO ENDIF DEALLOCATE(ZGTF) DEALLOCATE(ZAVE) DEALLOCATE(ZAVEG) DEALLOCATE(IVSETS) DEALLOCATE(IVSETG) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTLTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANS_CTLTL END MODULE GPNORM_TRANS_CTLTL_MOD ectrans-1.8.0/src/trans/cpu/internal/gath_grid_ctl_mod.F900000664000175000017500000002036715174631767023626 0ustar alastairalastair! (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. ! MODULE GATH_GRID_CTL_MOD CONTAINS SUBROUTINE GATH_GRID_CTL(PGPG,KFGATHG,KPROMA,KTO,PGP) !**** *GATH_GRID_CTL* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Routine for gathering gridpoint array !** Interface. ! ---------- ! CALL GATH_GRID_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! PGP(:,:,:) - Local gridpoint array ! ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_RECV, MPL_SEND, MPL_WAIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, MTAGDISTSP, NPRCIDS, MYPROC, NPROC USE SET2PE_MOD ,ONLY : SET2PE USE EQ_REGIONS_MOD ,ONLY : N_REGIONS, N_REGIONS_NS IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) REAL(KIND=JPRB) , INTENT(IN) :: PGP(:,:,:) ! Declaration of local variables REAL(KIND=JPRB) :: ZFLD(D%NGPTOTMX*KFGATHG) REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IREQ(:) INTEGER(KIND=JPIM) :: IFLDR,JFLD,ITAG,ILEN,JA,JB,ISND,JGL,JLON,ILOFF INTEGER(KIND=JPIM) :: IRCV,IOFF,ILAST,IGL1,IGL2,IGLOFF,IR INTEGER(KIND=JPIM) :: JKGLO,JROF,IEND,J,IBL,IPROC,JROC,IMYFIELDS,ILRECV INTEGER(KIND=JPIM) :: ISENDREQ(KFGATHG),ITO INTEGER(KIND=JPIM) :: ILENS(NPROC),IOFFS(NPROC),ILENR(NPROC),IOFFR(NPROC) INTEGER(KIND=JPIM) :: IFLDL,IFLDS LOGICAL :: LLSAME ! ------------------------------------------------------------------ !GATHER SPECTRAL ARRAY IF( NPROC == 1 ) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFGATHG DO JROF=1,IEND PGPG(IOFF+JROF,JFLD) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ! test if values in KTO are all the same LLSAME=.TRUE. ITO=KTO(1) DO JFLD=2,KFGATHG IF(KTO(JFLD) /= ITO) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO ! IF( MYPROC==1 )THEN ! WRITE(0,'("GATH_GRID_CTL DEBUG: LLSAME=",L1)')LLSAME ! DO JFLD=1,KFGATHG ! WRITE(0,'("GATH_GRID_CTL DEBUG:KFGATHG,JFLD,KTO=",3(2X,I6))')KFGATHG,JFLD,KTO(JFLD) ! ENDDO ! ENDIF IFLDL=D%NGPTOTMX IF(LLSAME) THEN CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JFLD=1,KFGATHG DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+(JFLD-1)*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ELSE ILENS(:)=0 IOFFS(:)=0 ILENR(:)=0 IOFFR(:)=0 DO JFLD=1,KFGATHG ILENS(KTO(JFLD))=ILENS(KTO(JFLD))+IFLDL IF(KTO(JFLD) == MYPROC) THEN ILENR(:)=ILENR(:)+IFLDL ENDIF ENDDO DO JROC=2,NPROC IOFFR(JROC)=IOFFR(JROC-1)+ ILENR(JROC-1) IOFFS(JROC)=IOFFS(JROC-1)+ ILENS(JROC-1) ENDDO IFLDS=0 DO JROC=1,NPROC IF(ILENS(JROC) > 0) THEN DO JFLD=1,KFGATHG IF(KTO(JFLD) == JROC) THEN DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JROF=1,IEND ZFLD(IOFF+JROF+IFLDS*IFLDL) = PGP(JROF,JFLD,IBL) ENDDO ENDDO IFLDS=IFLDS+1 ENDIF ENDDO ENDIF ENDDO ENDIF IMYFIELDS = 0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX*IMYFIELDS*NPROC)) ELSE ALLOCATE(ZBUF(1)) ENDIF IFLDR = 0 CALL GSTATS_BARRIER(789) CALL GSTATS(809,0) IF( LLSAME )THEN !Send ISND = KTO(1) ITAG = MTAGDISTSP+1+17 CALL MPL_SEND(ZFLD,KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(1),& &CDSTRING='GATH_GRID_CTL:') ! RECIEVE IF(KTO(1) == MYPROC) THEN IFLDR = KFGATHG DO JROC=1,NPROC ITAG = MTAGDISTSP+1+17 IRCV = JROC IOFF=IFLDL*KFGATHG*(JROC-1) CALL MPL_RECV(ZBUF(IOFF+1:IOFF+IFLDL*KFGATHG),KSOURCE=NPRCIDS(IRCV),& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILRECV,& &KTAG=ITAG,CDSTRING='GATH_GRID_CTL:') ENDDO ENDIF CALL MPL_WAIT(KREQUEST=ISENDREQ(1), & & CDSTRING='GATH_GRID_CTL: WAIT') ELSE IFLDR=IMYFIELDS ! ALLTOALLV performance is really slow when number of fields (KFGATHG) is << NPROC ! This was for IBM - and RECV/SEND alternative causes problems for large number of MPI tasks. ! IF( KFGATHG >= NPROC/8 )THEN IF( .TRUE. )THEN CALL MPL_ALLTOALLV(PSENDBUF=ZFLD,KSENDCOUNTS=ILENS,& & PRECVBUF=ZBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& & CDSTRING='GATH_GRID_CTL:') ELSE IR=0 DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IR=IR+NPROC ENDIF ENDDO IR=IR+KFGATHG ALLOCATE(IREQ(IR)) IR=0 ITAG = MTAGDISTSP+1+17 DO JROC=1,NPROC DO JFLD=1,KFGATHG IF(KTO(JFLD) == MYPROC) THEN IRCV = JROC IR=IR+1 CALL MPL_RECV(ZBUF(1+IOFFR(IRCV):IOFFR(IRCV)+ILENR(IRCV)),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR),& &CDSTRING='GATH_GRID_CTL:') ENDIF ENDDO ENDDO DO JFLD=1,KFGATHG ISND = KTO(JFLD) IR=IR+1 CALL MPL_SEND(ZFLD(1+IOFFS(ISND):IOFFS(ISND)+ILENS(ISND)),KDEST=NPRCIDS(ISND),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR),& &CDSTRING='GATH_GRID_CTL:') ENDDO CALL MPL_WAIT(KREQUEST=IREQ(1:IR), & & CDSTRING='GATH_GRID_CTL: WAIT') DEALLOCATE(IREQ) ENDIF ENDIF CALL GSTATS(809,1) CALL GSTATS_BARRIER2(789) CALL GSTATS(1643,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JA,JB,IPROC,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILEN,ILOFF,JGL,JLON,JFLD) DO JFLD=1,IFLDR DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(IPROC,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) = & & ZBUF(ILEN+JLON+(JFLD-1)*IFLDL+(IPROC-1)*IFLDL*IMYFIELDS) ENDDO ILEN = ILEN + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1643,1) ! Synhronize processors ! Should not be necessary !!$ CALL GSTATS(784,0) !!$ CALL MPL_BARRIER(CDSTRING='GATH_GRID_CTL:') !!$ CALL GSTATS(784,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID_CTL END MODULE GATH_GRID_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/fourier_out_mod.F900000664000175000017500000000475215174631767023376 0ustar alastairalastair! (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. ! MODULE FOURIER_OUT_MOD CONTAINS SUBROUTINE FOURIER_OUT(PREEL, KFIELDS, KGL) !**** *FOURIER_OUT* - Copy fourier data from local array to buffer ! Purpose. ! -------- ! Routine for copying fourier data from local array to buffer !** Interface. ! ---------- ! CALL FOURIER_OUT(...) ! Explicit arguments : PREEL - local fourier/GP array ! -------------------- KFIELDS - number of fields ! KGL - local index of latitude we are currently on ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND1, ONLY : JPIM, JPRB USE TPM_DISTR, ONLY : D, MYSETW USE TPM_TRANS, ONLY : FOUBUF_IN USE TPM_GEOMETRY, ONLY : G IMPLICIT NONE REAL(KIND=JPRB), INTENT(IN) :: PREEL(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KGL INTEGER(KIND=JPIM) :: JM, JF, IGLG, IPROC, IR, II, ISTA ! ------------------------------------------------------------------ ! Determine global latitude index corresponding to local latitude index KGL IGLG = D%NPTRLS(MYSETW) + KGL - 1 ! Loop over all zonal wavenumbers relevant for this latitude DO JM = 0, G%NMEN(IGLG) ! Get the member of the W-set responsible for this zonal wavenumber in the "m" representation IPROC = D%NPROCM(JM) ! Compute offset in FFT work array PREEL corresponding to wavenumber JM and latitude KGL IR = 2 * JM + 1 + D%NSTAGTF(KGL) II = 2 * JM + 2 + D%NSTAGTF(KGL) ! Compute offset for insertion of the fields in the l-to-m transposition buffer, FOUBUF_IN ISTA = (D%NSTAGT1B(D%MSTABF(IPROC)) + D%NPNTGTB0(JM,KGL)) * 2 * KFIELDS ! Copy all fields from FFT work array to l-to-m transposition buffer DO JF = 1, KFIELDS FOUBUF_IN(ISTA+2*JF-1) = PREEL(JF,IR) FOUBUF_IN(ISTA+2*JF) = PREEL(JF,II) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FOURIER_OUT END MODULE FOURIER_OUT_MODectrans-1.8.0/src/trans/cpu/internal/gath_spec_control_mod.F900000664000175000017500000002356215174631767024531 0ustar alastairalastair! (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. ! MODULE GATH_SPEC_CONTROL_MOD CONTAINS SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& & KSMAX,KSPEC2,KSPEC2MX,KSPEC2G,KPOSSP,KDIM0G,KUMPP,KALLMS,KPTRMS,KN,LDZA0IP) !**** *GATH_SPEC_CONTROL* - Gather global spectral array from processors ! Purpose. ! -------- ! Routine for gathering spectral array !** Interface. ! ---------- ! CALL GATH_SPEC_CONTROL(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for distributing each field ! KVSET(:) - "B-Set" for each field ! PSPEC(:,:) - Local spectral array ! LDIM1_IS_FLD - .TRUE. if first dimension contains the fields ! KSMAX - Spectral truncation limit ! KSPEC2 - Local number of spectral coefficients ! KSPEC2MX - Maximum local number of spectral coefficients ! KSPEC2G - Global number of spectral coefficients ! KPOSSP - Position of local waves for each task ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KUMPP - Number of spectral waves on this a-set ! KALLMS - Wave numbers for all a-set concatenated together to give all wave numbers in a-set order ! KPTRMS - Pointer to the first wave number of a given a-set in kallms array. ! KN - Number of spectral coefficients for each m wave ! LDZA0IP - Set first coefficients (imaginary part) to zero (global model only) ! Externals. SET2PE - compute "A and B" set from PE ! ---------- MPL.. - message passing routines ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! R. El Khatib 02-Dec-2020 re-write for optimizations and merge with LAM counterpart ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : MTAGDISTSP, NPRCIDS, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC, NPRTRV USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE SET2PE_MOD ,ONLY : SET2PE USE TPM_GEOMETRY ,ONLY : G IMPLICIT NONE REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2MX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2G INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) INTEGER(KIND=JPIM) , INTENT(IN) :: KUMPP(NPRTRW) INTEGER(KIND=JPIM) , INTENT(IN) :: KALLMS(KSMAX+1) INTEGER(KIND=JPIM) , INTENT(IN) :: KPTRMS(NPRTRW) INTEGER(KIND=JPIM) , INTENT(IN) :: KN(0:KSMAX) LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP REAL(KIND=JPRB) :: ZBUFSEND(KSPEC2MX,COUNT(KVSET(1:KFGATHG) == MYSETV)) REAL(KIND=JPRB) :: ZRECV(KSPEC2MX,COUNT(KTO(1:KFGATHG) == MYPROC)) INTEGER(KIND=JPIM) :: IASM0G(0:KSMAX) INTEGER(KIND=JPIM) :: JM,JN,II,IFLDR,IFLDS,JFLD,ITAG,IB,ILEN(NPRTRW),JA,JB,ISND,JMLOC INTEGER(KIND=JPIM) :: IPE(NPRTRV,NPRTRW),ILENR,ISENDREQ(NPROC),IPOSSP,JNM,JROC INTEGER(KIND=JPIM) :: IFLD,IFLDLOC(COUNT(KTO(1:KFGATHG) == MYPROC)),IOFFPROC INTEGER(KIND=JPIM) :: ILOCFLD(COUNT(KVSET(1:KFGATHG) == MYSETV)) LOGICAL :: LLZA0IP ! ------------------------------------------------------------------ ! Compute help array for distribution DO JA=1,NPRTRW ILEN(JA) = KPOSSP(JA+1)-KPOSSP(JA) ENDDO DO JA=1,NPRTRW DO JB=1,NPRTRV CALL SET2PE(IPE(JB,JA),0,0,JA,JB) ENDDO ENDDO IASM0G(0)=1 DO JM=1,KSMAX IASM0G(JM)=IASM0G(JM-1)+KN(JM-1) ENDDO LLZA0IP=.NOT.G%LAM ! or it should have been coded in the original code, please :-( IF (PRESENT (LDZA0IP)) LLZA0IP=LDZA0IP !GATHER SPECTRAL ARRAY !Send ISND=0 IOFFPROC=0 IF (KSPEC2 > 0) THEN CALL GSTATS(810,0) DO JROC=1,NPROC IF (JROC /= MYPROC) THEN IFLD=0 ! counter of fields in PSPEC IFLDS=0 ! counter of fields in ZBUFSEND DO JFLD=1,KFGATHG IF (KVSET(JFLD) == MYSETV) THEN IFLD=IFLD+1 IF (JROC==KTO(JFLD)) THEN IFLDS=IFLDS+1 IF (LDIM1_IS_FLD) THEN ZBUFSEND(1:KSPEC2,IOFFPROC+IFLDS)=PSPEC(IFLD,1:KSPEC2) ELSE ZBUFSEND(1:KSPEC2,IOFFPROC+IFLDS)=PSPEC(1:KSPEC2,IFLD) ENDIF ENDIF ENDIF ENDDO IF (IFLDS > 0) THEN ITAG=MTAGDISTSP+MYPROC ISND=ISND+1 CALL MPL_SEND(ZBUFSEND(:,IOFFPROC+1:IOFFPROC+IFLDS),KDEST=NPRCIDS(JROC),KTAG=ITAG,& & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISND),& & CDSTRING='GATH_SPEC_CONTROL') ENDIF IOFFPROC=IOFFPROC+IFLDS ENDIF ENDDO CALL GSTATS(810,1) ! Myself : IFLD=0 IFLDR=0 DO JFLD=1,KFGATHG IF (KTO(JFLD) == MYPROC) THEN IFLD=IFLD+1 IF (KVSET(JFLD)==MYSETV) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IFLD=0 IFLDR=0 DO JFLD=1,KFGATHG IF (KVSET(JFLD)==MYSETV) THEN IFLD=IFLD+1 IF (KTO(JFLD) == MYPROC) THEN IFLDR = IFLDR+1 ILOCFLD(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN IF (LDIM1_IS_FLD) THEN CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) DO JFLD=1,IFLDR DO JMLOC=1,KUMPP(MYSETW) JM=KALLMS(KPTRMS(MYSETW)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(MYSETW)+1 PSPECG(IFLDLOC(JFLD),IASM0G(JM):IASM0G(JM)+KN(JM)-1)=PSPEC(ILOCFLD(JFLD),IPOSSP:IPOSSP+KN(JM)-1) ENDDO IF (LLZA0IP) THEN II = 0 DO JN=0,KSMAX II = II+2 PSPECG(IFLDLOC(JFLD),II) = 0.0_JPRB ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) ELSE CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) DO JFLD=1,IFLDR DO JMLOC=1,KUMPP(MYSETW) JM=KALLMS(KPTRMS(MYSETW)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(MYSETW)+1 PSPECG(IASM0G(JM):IASM0G(JM)+KN(JM)-1,IFLDLOC(JFLD))=PSPEC(IPOSSP:IPOSSP+KN(JM)-1,ILOCFLD(JFLD)) ENDDO IF (LLZA0IP) THEN II = 0 DO JN=0,KSMAX II = II+2 PSPECG(II,IFLDLOC(JFLD)) = 0.0_JPRB ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) ENDIF ENDIF ENDIF ! Receive DO JA=1,NPRTRW IF (ILEN(JA) > 0) THEN DO JB=1,NPRTRV IF (IPE(JB,JA) /= MYPROC) THEN ! Locate received fields in source array : IFLD=0 IFLDR=0 DO JFLD=1,KFGATHG IF (KTO(JFLD) == MYPROC) THEN IFLD=IFLD+1 IF (KVSET(JFLD)==JB) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN ITAG=MTAGDISTSP+IPE(JB,JA) CALL GSTATS(810,0) CALL MPL_RECV(ZRECV(:,1:IFLDR),KSOURCE=NPRCIDS(IPE(JB,JA)),KTAG=ITAG,& & KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & & CDSTRING='GATH_SPEC_CONTROL') IF (ILENR /= KSPEC2MX*IFLDR) THEN CALL ABORT_TRANS('GATH_SPEC_CONTROL:INVALID RECEIVE MESSAGE LENGTH') ENDIF CALL GSTATS(810,1) CALL GSTATS(1644,0) IF (LDIM1_IS_FLD) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) DO JFLD=1,IFLDR DO JMLOC=1,KUMPP(JA) JM=KALLMS(KPTRMS(JA)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(JA)+1 PSPECG(IFLDLOC(JFLD),IASM0G(JM):IASM0G(JM)+KN(JM)-1)=ZRECV(IPOSSP:IPOSSP+KN(JM)-1,JFLD) ENDDO IF (LLZA0IP) THEN II = 0 DO JN=0,KSMAX II = II+2 PSPECG(IFLDLOC(JFLD),II) = 0.0_JPRB ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IPOSSP,II,JN) DO JFLD=1,IFLDR DO JMLOC=1,KUMPP(JA) JM=KALLMS(KPTRMS(JA)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(JA)+1 PSPECG(IASM0G(JM):IASM0G(JM)+KN(JM)-1,IFLDLOC(JFLD))=ZRECV(IPOSSP:IPOSSP+KN(JM)-1,JFLD) ENDDO IF (LLZA0IP) THEN II = 0 DO JN=0,KSMAX II = II+2 PSPECG(II,IFLDLOC(JFLD)) = 0.0_JPRB ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1644,1) ENDIF ENDIF ENDDO ENDIF ENDDO CALL GSTATS_BARRIER2(788) ! Check for completion of sends CALL GSTATS(810,0) IF (ISND > 0) THEN CALL MPL_WAIT(ISENDREQ(1:ISND),CDSTRING='GATH_GRID_CTL: WAIT') ENDIF CALL GSTATS(810,1) !Synchronize processors. Useful ?? CALL GSTATS(785,0) !rekCALL MPL_BARRIER(CDSTRING='GATH_SPEC_CONTROL:') CALL GSTATS(785,1) CALL GSTATS_BARRIER(788) ! ------------------------------------------------------------------ END SUBROUTINE GATH_SPEC_CONTROL END MODULE GATH_SPEC_CONTROL_MOD ectrans-1.8.0/src/trans/cpu/internal/ltdir_ctl_mod.F900000664000175000017500000000620315174631767023005 0ustar alastairalastair! (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. ! MODULE LTDIR_CTL_MOD CONTAINS SUBROUTINE LTDIR_CTL(KF_FS,KF_UV,KF_SCALARS, & & PSPVOR,PSPDIV,PSPSCALAR, & & PSPSC3A,PSPSC3B,PSPSC2, & & KFLDPTRUV,KFLDPTRSC) !**** *LTDIR_CTL* - Control routine for direct Legendre transform ! Purpose. ! -------- ! Direct Legendre transform !** Interface. ! ---------- ! CALL LTDIR_CTL(...) ! Explicit arguments : ! -------------------- ! KF_FS - number of fields in Fourier space ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! KFLDPTRUV(:) - field pointer for vorticity and divergence (input) ! KFLDPTRSC(:) - field pointer for scalarvalued fields (input) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : LALLOPERM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE LTDIR_MOD ,ONLY : LTDIR USE TRLTOM_MOD ,ONLY : TRLTOM ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS 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(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILED2 ! ------------------------------------------------------------------ ! Transposition from Fourier space distribution to spectral space distribution IBLEN = D%NLENGT0B*2*KF_FS IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF CALL GSTATS(153,0) CALL TRLTOM(FOUBUF_IN,FOUBUF,2*KF_FS) CALL GSTATS(153,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) ! Direct Legendre transform CALL GSTATS(103,0) ILED2 = 2*KF_FS CALL GSTATS(1645,0) IF(KF_FS>0) THEN !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL LTDIR(IM,JM,KF_FS,KF_UV,KF_SCALARS,ILED2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1645,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) CALL GSTATS(103,1) ! ----------------------------------------------------------------- END SUBROUTINE LTDIR_CTL END MODULE LTDIR_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/fspgl_int_mod.F900000664000175000017500000000571515174631767023021 0ustar alastairalastair! (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. ! MODULE FSPGL_INT_MOD CONTAINS SUBROUTINE FSPGL_INT(KM,KMLOC,KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT,& & FSPGL_PROC,KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF_IN, LDIVGP, LVORGP USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D USE TPM_FIELDS ,ONLY : F USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV,KF_SCALARS,KF_SCDERS,KF_OUT_LT EXTERNAL FSPGL_PROC INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! ! ZFIELD 2nd dimension is extended from 0 to R%NDGL+1, while only 1 to R%NDGL ! is given from the north/south transforms, and only 1 to R%NDGL rows will be ! passed to the east/west transforms. ! the 2 extra rows are used inside the model Fourier space computations ! (outside the transform package - see FSPGLH in Arpege/IFS). ! REAL(KIND=JPRB) :: ZFIELD(2*KF_OUT_LT,0:R%NDGL+1) INTEGER(KIND=JPIM) :: ISL, IGLS, JFLD, JGL ,IPROC, IPROCS INTEGER(KIND=JPIM) :: IPTRU,IST,J INTEGER(KIND=JPIM) :: IDGNH,IDGL INTEGER(KIND=JPIM) :: ISTAN(R%NDGNH),ISTAS(R%NDGNH) INTEGER(KIND=JPIM) :: IFLDPTRUV(KF_UV),IFLDPTRSC(KF_SCALARS) ! ------------------------------------------------------------------ IF(PRESENT(KFLDPTRUV)) THEN IFLDPTRUV(:) = KFLDPTRUV(1:KF_UV) IFLDPTRSC(:) = KFLDPTRSC(1:KF_SCALARS) ELSE DO J=1,KF_UV IFLDPTRUV(J) = J ENDDO DO J=1,KF_SCALARS IFLDPTRSC(J) = J ENDDO ENDIF ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IDGNH = R%NDGNH IDGL = R%NDGL DO JGL=ISL,IDGNH IPROC = D%NPROCL(JGL) ISTAN(JGL) = (D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*2*KF_OUT_LT IGLS = IDGL+1-JGL IPROCS = D%NPROCL(IGLS) ISTAS(JGL) = (D%NSTAGT0B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*2*KF_OUT_LT ENDDO DO JGL=ISL,IDGNH IGLS = IDGL+1-JGL DO JFLD=1,2*KF_OUT_LT ZFIELD(JFLD,JGL) = FOUBUF_IN(ISTAN(JGL)+JFLD) ZFIELD(JFLD,IGLS) = FOUBUF_IN(ISTAS(JGL)+JFLD) ENDDO ENDDO IST = 1 IF(LVORGP) THEN IST = IST+2*KF_UV ENDIF IF(LDIVGP) THEN IST = IST+2*KF_UV ENDIF IPTRU = IST CALL FSPGL_PROC(KM,ISL,IDGL,KF_OUT_LT,F%R1MU2,ZFIELD,& & IPTRU,KF_UV,KF_SCALARS,& & IFLDPTRUV) DO JGL=ISL,IDGNH IGLS = IDGL+1-JGL !OCL NOVREC DO JFLD=1,2*KF_OUT_LT FOUBUF_IN(ISTAN(JGL)+JFLD) = ZFIELD(JFLD,JGL) FOUBUF_IN(ISTAS(JGL)+JFLD) = ZFIELD(JFLD,IGLS) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FSPGL_INT END MODULE FSPGL_INT_MOD ectrans-1.8.0/src/trans/cpu/internal/gpnorm_trans_ctl_mod.F900000664000175000017500000002730115174631767024402 0ustar alastairalastair! (C) Copyright 2008- ECMWF. ! (C) Copyright 2008- 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. ! MODULE GPNORM_TRANS_CTL_MOD CONTAINS SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) !**** *GPNORM_TRANS_CTL* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL GPNORM_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! Modifications. ! -------------- ! Original : 19th Sept 2008 ! R. El Khatib 07-08-2009 Optimisation directive for NEC ! R. El Khatib 16-Sep-2019 merge with LAM code ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! F. Vana 14-Nov-2024 bug fix in W gather ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD !ifndef INTERFACE USE TPM_GEN ,ONLY : NOUT USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LGPNORM, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRV, NPRTRW, MYSETV, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TRGTOL_MOD ,ONLY : TRGTOL USE SET2PE_MOD ,ONLY : SET2PE USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, JP_BLOCKING_STANDARD USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL ,INTENT(IN) :: LDAVE_ONLY REAL(KIND=JPRD) ,INTENT(IN) :: PW(R%NDGL) !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IUBOUND(4) INTEGER(KIND=JPIM) :: IVSET(KFIELDS) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZGTF(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZMINGL(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZMAXGL(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZMIN(:) REAL(KIND=JPRB),ALLOCATABLE :: ZMAX(:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVEG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZMING(:) REAL(KIND=JPRB),ALLOCATABLE :: ZMAXG(:) REAL(KIND=JPRD),ALLOCATABLE :: ZSND(:) REAL(KIND=JPRD),ALLOCATABLE :: ZRCV(:) INTEGER(KIND=JPIM) :: J,JGL,IGL,JL,JF,IF_GP,IF_SCALARS_G,IF_FS,JSETV,JSETW,IWLATS INTEGER(KIND=JPIM) :: IPROC,ITAG,ILEN,ILENR,IBEG,IEND,IND ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTL',0,ZHOOK_HANDLE) ! Set defaults NPROMA = KPROMA NGPBLKS = (D%NGPTOT-1)/NPROMA+1 ! Consistency checks IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTL:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('GPNORM_TRANS_CTL:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFIELDS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTL:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFIELDS CALL ABORT_TRANS('GPNORM_TRANS_CTL:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTL:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('GPNORM_TRANS_CTL:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF_GP=KFIELDS IF_SCALARS_G=0 IF_FS=0 DO J=1,KFIELDS IVSET(J)=MOD(J-1,NPRTRV)+1 IF(IVSET(J)==MYSETV)THEN IF_FS=IF_FS+1 ENDIF ENDDO ALLOCATE(IVSETS(NPRTRV)) IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 ENDDO ALLOCATE(IVSETG(NPRTRV,MAXVAL(IVSETS(:)))) IVSETG(:,:)=0 IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 IVSETG(IVSET(J),IVSETS(IVSET(J)))=J ENDDO ALLOCATE(ZGTF(IF_FS,D%NLENGTF)) IF (SIZE(ZGTF) > 0) ZGTF(1,1)=0._JPRB ! force allocation right here, not inside an omp region below LGPNORM=.TRUE. CALL TRGTOL(ZGTF,IF_FS,IF_GP,IF_SCALARS_G,IVSET,PGP=PGP) LGPNORM=.FALSE. IBEG=1 IEND=D%NDGL_FS ALLOCATE(ZAVE(IF_FS,IBEG:IEND)) ALLOCATE(ZMIN(IF_FS)) ALLOCATE(ZMAX(IF_FS)) IF(.NOT.LDAVE_ONLY)THEN ALLOCATE(ZMINGL(IF_FS,IBEG:IEND)) ALLOCATE(ZMAXGL(IF_FS,IBEG:IEND)) ENDIF IF( IF_FS > 0 )THEN ZAVE(:,:)=0.0_JPRB IF(.NOT.LDAVE_ONLY)THEN DO JF=1,IF_FS ZMINGL(JF,:)=ZGTF(JF,D%NSTAGTF(1)+1) ZMAXGL(JF,:)=ZGTF(JF,D%NSTAGTF(1)+1) ENDDO ENDIF ! FIRST DO SUMS IN EACH FULL LATITUDE CALL GSTATS(1429,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JGL,IGL,JF,JL) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 !CDIR NOLOOPCHG DO JF=1,IF_FS !DIR$ NEXTSCALAR DO JL=1,G%NLOEN(IGL) ZAVE(JF,JGL)=ZAVE(JF,JGL)+ZGTF(JF,D%NSTAGTF(JGL)+JL) ENDDO IF(.NOT.LDAVE_ONLY)THEN DO JL=1,G%NLOEN(IGL) ZMINGL(JF,JGL)=MIN(ZMINGL(JF,JGL),ZGTF(JF,D%NSTAGTF(JGL)+JL)) ZMAXGL(JF,JGL)=MAX(ZMAXGL(JF,JGL),ZGTF(JF,D%NSTAGTF(JGL)+JL)) ENDDO ENDIF ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1429,1) IF(.NOT.LDAVE_ONLY)THEN DO JF=1,IF_FS ZMIN(JF)=MINVAL(ZMINGL(JF,:)) ZMAX(JF)=MAXVAL(ZMAXGL(JF,:)) ENDDO DEALLOCATE(ZMINGL) DEALLOCATE(ZMAXGL) ENDIF DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=ZAVE(JF,JGL)*REAL(PW(IGL),JPRB)/G%NLOEN(IGL) ENDDO ENDDO ENDIF ! IT IS IMPORTANT THAT SUMS ARE NOW DONE IN LATITUDE ORDER ALLOCATE(ZAVEG(R%NDGL,KFIELDS)) ALLOCATE(ZMING(KFIELDS)) ALLOCATE(ZMAXG(KFIELDS)) ZAVEG(:,:)=0.0_JPRB DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 ZAVEG(IGL,IVSETG(MYSETV,JF))=ZAVEG(IGL,IVSETG(MYSETV,JF))+ZAVE(JF,JGL) ENDDO ENDDO IF(LDAVE_ONLY)THEN ZMING(:)=PMIN(:) ZMAXG(:)=PMAX(:) ELSE DO JF=1,IF_FS ZMING(IVSETG(MYSETV,JF))=ZMIN(JF) ZMAXG(IVSETG(MYSETV,JF))=ZMAX(JF) ENDDO ENDIF ! RECEIVE ABOVE FROM OTHER NPRTRV SETS FOR SAME LATS BUT DIFFERENT FIELDS ITAG=123 CALL GSTATS(815,0) IF( MYSETV==1 )THEN DO JSETV=2,NPRTRV IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*IVSETS(JSETV)+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*IVSETS(JSETV) ENDIF IF(ILEN > 0)THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,MYSETW,JSETV) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS_CTL:V') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTL:ILENR /= ILEN') ENDIF IND=0 DO JF=1,IVSETS(JSETV) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,IVSETG(JSETV,JF))=ZRCV(IND) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZMING(IVSETG(JSETV,JF))=ZRCV(IND) IND=IND+1 ZMAXG(IVSETG(JSETV,JF))=ZRCV(IND) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),KIND=JPRB)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),KIND=JPRB)) ENDDO ENDIF DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IF(LDAVE_ONLY)THEN ILEN=D%NDGL_FS*IVSETS(MYSETV)+2*KFIELDS ELSE ILEN=(D%NDGL_FS+2)*IVSETS(MYSETV) ENDIF IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,MYSETW,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,IVSETG(MYSETV,JF)) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZSND(IND)=ZMING(IVSETG(MYSETV,JF)) IND=IND+1 ZSND(IND)=ZMAXG(IVSETG(MYSETV,JF)) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZSND(IND)=PMIN(JF) IND=IND+1 ZSND(IND)=PMAX(JF) ENDDO ENDIF CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTL:V') DEALLOCATE(ZSND) ENDIF ENDIF ! FINALLY RECEIVE CONTRIBUTIONS FROM OTHER NPRTRW SETS IF( MYSETV == 1 )THEN IF( MYSETW == 1 )THEN DO JSETW=2,NPRTRW IWLATS=D%NULTPP(JSETW) IF(LDAVE_ONLY)THEN ILEN=IWLATS*KFIELDS+2*KFIELDS ELSE ILEN=(IWLATS+2)*KFIELDS ENDIF IF(ILEN > 0 )THEN ALLOCATE(ZRCV(ILEN)) CALL SET2PE(IPROC,0,0,JSETW,1) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='GPNORM_TRANS_CTL:W') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTL:ILENR /= ILEN') ENDIF IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(JSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,JF)=ZRCV(IND) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),KIND=JPRB)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),KIND=JPRB)) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),KIND=JPRB)) IND=IND+1 ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),KIND=JPRB)) ENDDO ENDIF DEALLOCATE(ZRCV) ENDIF ENDDO ELSE IWLATS=D%NULTPP(MYSETW) IF(LDAVE_ONLY)THEN ILEN=IWLATS*KFIELDS+2*KFIELDS ELSE ILEN=(IWLATS+2)*KFIELDS ENDIF IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,1,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,JF) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 ZSND(IND)=ZMING(JF) IND=IND+1 ZSND(IND)=ZMAXG(JF) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 ZSND(IND)=ZMING(JF) IND=IND+1 ZSND(IND)=ZMAXG(JF) ENDDO ENDIF CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTL:W') DEALLOCATE(ZSND) ENDIF ENDIF ENDIF CALL GSTATS(815,1) IF( MYSETW == 1 .AND. MYSETV == 1 )THEN PAVE(:)=0.0_JPRB DO JGL=1,R%NDGL PAVE(:)=PAVE(:)+ZAVEG(JGL,:) ENDDO PMIN(:)=ZMING(:) PMAX(:)=ZMAXG(:) ENDIF DEALLOCATE(ZGTF) DEALLOCATE(ZAVE) DEALLOCATE(ZMIN) DEALLOCATE(ZMAX) DEALLOCATE(ZAVEG) DEALLOCATE(ZMING) DEALLOCATE(ZMAXG) DEALLOCATE(IVSETS) DEALLOCATE(IVSETG) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANS_CTL END MODULE GPNORM_TRANS_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/prfi2ad_mod.F900000664000175000017500000000604015174631767022353 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE PRFI2AD_MOD CONTAINS SUBROUTINE PRFI2AD(KM,KMLOC,KF_FS,PAIA,PSIA) !**** *PRFI2AD* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *PRFI2AD(..) ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAIA - antisymmetric part of Fourier ! components for KM (output) ! PSIA - symmetric part of Fourier ! components for KM (output) ! Implicit arguments : The Grid point arrays of the model. ! -------------------- ! Method. ! ------- ! Externals. PRFI2ADB - basic copying routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-25 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 93-03-19 D. Giard - CDCONF='T' ! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' ! Modified : 93-05-13 D. Giard - correction of the previous bug ! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE PRFI2BAD_MOD ,ONLY : PRFI2BAD ! IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KM INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS REAL(KIND=JPRB) , INTENT(IN) :: PSIA(:,:), PAIA(:,:) ! ------------------------------------------------------------------ !* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. ! ------------------------------------------- CALL PRFI2BAD(KF_FS,KM,KMLOC,PAIA,PSIA) ! ------------------------------------------------------------------ END SUBROUTINE PRFI2AD END MODULE PRFI2AD_MOD ectrans-1.8.0/src/trans/cpu/internal/fsc_mod.F900000664000175000017500000001224515174631767021603 0ustar alastairalastair! (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. ! MODULE FSC_MOD CONTAINS SUBROUTINE FSC(KGL,KF_UV,KF_SCALARS,KF_SCDERS,& & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) !**** *FSC - Division by a*cos(theta), east-west derivatives ! Purpose. ! -------- ! In Fourier space divide u and v and all north-south ! derivatives by a*cos(theta). Also compute east-west derivatives ! of u,v,thermodynamic, passiv scalar variables and surface ! pressure. !** Interface. ! ---------- ! CALL FSC(..) ! Explicit arguments : PUV - u and v ! -------------------- PSCALAR - scalar valued varaibles ! PNSDERS - N-S derivative of S.V.V. ! PEWDERS - E-W derivative of S.V.V. ! PUVDERS - E-W derivative of u and v ! Method. ! ------- ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 (From SC2FSC) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_TRANS ,ONLY : LUVDER, LATLON USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_FIELDS ,ONLY : F USE TPM_GEOMETRY ,ONLY : G USE TPM_FLT ,ONLY: S ! IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KGL,KF_UV,KF_SCALARS,KF_SCDERS REAL(KIND=JPRB) , INTENT(INOUT) :: PUV(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PSCALAR(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PNSDERS(:,:) REAL(KIND=JPRB) , INTENT( OUT) :: PEWDERS(:,:) REAL(KIND=JPRB) , INTENT( OUT) :: PUVDERS(:,:) REAL(KIND=JPRB) :: ZACHTE,ZMUL, ZACHTE2, ZSHIFT, ZPI REAL(KIND=JPRB) :: ZAMP, ZPHASE INTEGER(KIND=JPIM) :: IMEN,ISTAGTF INTEGER(KIND=JPIM) :: JLON,JF,IGLG,II,IR,JM ! ------------------------------------------------------------------ IGLG = D%NPTRLS(MYSETW)+KGL-1 ZACHTE = REAL(F%RACTHE(IGLG),JPRB) IMEN = G%NMEN(IGLG) ISTAGTF = D%NSTAGTF(KGL) ZACHTE2 = REAL(F%RACTHE(IGLG),JPRB) IF( LATLON.AND.S%LDLL ) THEN ZPI = 2.0_JPRB*ASIN(1.0_JPRB) ZACHTE2 = 1._JPRB ZACHTE = REAL(F%RACTHE2(IGLG),JPRB) ! apply shift for (even) lat-lon output grid IF( S%LSHIFTLL ) THEN ZSHIFT = ZPI/REAL(G%NLOEN(IGLG),JPRB) DO JF=1,KF_SCALARS DO JM=0,IMEN IR = ISTAGTF+2*JM+1 II = IR+1 ! calculate amplitude and add phase shift then reconstruct A,B ZAMP = SQRT(PSCALAR(JF,IR)**2 + PSCALAR(JF,II)**2) ZPHASE = ATAN2(PSCALAR(JF,II),PSCALAR(JF,IR)) + REAL(JM,JPRB)*ZSHIFT PSCALAR(JF,IR) = ZAMP*COS(ZPHASE) PSCALAR(JF,II) = ZAMP*SIN(ZPHASE) ENDDO ENDDO IF(KF_SCDERS > 0)THEN DO JF=1,KF_SCALARS DO JM=0,IMEN IR = ISTAGTF+2*JM+1 II = IR+1 ! calculate amplitude and phase shift and reconstruct A,B ZAMP = SQRT(PNSDERS(JF,IR)**2 + PNSDERS(JF,II)**2) ZPHASE = ATAN2(PNSDERS(JF,II),PNSDERS(JF,IR)) + REAL(JM,JPRB)*ZSHIFT PNSDERS(JF,IR) = ZAMP*COS(ZPHASE) PNSDERS(JF,II) = ZAMP*SIN(ZPHASE) ENDDO ENDDO ENDIF DO JF=1,2*KF_UV DO JM=0,IMEN IR = ISTAGTF+2*JM+1 II = IR+1 ! calculate amplitude and phase shift and reconstruct A,B ZAMP = SQRT(PUV(JF,IR)**2 + PUV(JF,II)**2) ZPHASE = ATAN2(PUV(JF,II),PUV(JF,IR)) + REAL(JM,JPRB)*ZSHIFT PUV(JF,IR) = ZAMP*COS(ZPHASE) PUV(JF,II) = ZAMP*SIN(ZPHASE) ENDDO ENDDO ENDIF ENDIF ! ------------------------------------------------------------------ !* 1. DIVIDE U V AND N-S DERIVATIVES BY A*COS(THETA) ! ---------------------------------------------- !* 1.1 U AND V. IF(KF_UV > 0) THEN DO JLON=ISTAGTF+1,ISTAGTF+2*(IMEN+1) DO JF=1,2*KF_UV PUV(JF,JLON) = PUV(JF,JLON)*ZACHTE2 ENDDO ENDDO ENDIF !* 1.2 N-S DERIVATIVES IF(KF_SCDERS > 0)THEN DO JLON=ISTAGTF+1,ISTAGTF+2*(IMEN+1) DO JF=1,KF_SCALARS PNSDERS(JF,JLON) = PNSDERS(JF,JLON)*ZACHTE2 ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ !* 2. EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. IF(LUVDER)THEN DO JM=0,IMEN IR = ISTAGTF+2*JM+1 II = IR+1 ZMUL = ZACHTE*JM DO JF=1,2*KF_UV PUVDERS(JF,IR) = -PUV(JF,II)*ZMUL PUVDERS(JF,II) = PUV(JF,IR)*ZMUL ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES IF(KF_SCDERS > 0)THEN DO JM=0,IMEN IR = ISTAGTF+2*JM+1 II = IR+1 ZMUL = ZACHTE*JM DO JF=1,KF_SCALARS PEWDERS(JF,IR) = -PSCALAR(JF,II)*ZMUL PEWDERS(JF,II) = PSCALAR(JF,IR)*ZMUL ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE FSC END MODULE FSC_MOD ectrans-1.8.0/src/trans/cpu/internal/ftdir_mod.F900000664000175000017500000000451115174631767022135 0ustar alastairalastair! (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. ! MODULE FTDIR_MOD CONTAINS SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) !**** *FTDIR - Direct Fourier transform ! Purpose. Routine for Grid-point to Fourier transform ! -------- !** Interface. ! ---------- ! CALL FTDIR(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELDS - number of fields ! Method. ! ------- ! Externals. FFTW - FFT routine ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti 01-04-24 2D model (NLOEN=1) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPIB, JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TPM_FFTW ,ONLY : TW, EXEC_FFTW USE TPM_DIM ,ONLY : R ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL REAL(KIND=JPRB), POINTER, CONTIGUOUS, INTENT(INOUT) :: PREEL(:,:) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,JJ,IST1 INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN, ITYPE ! ------------------------------------------------------------------ ITYPE=-1 IGLG = D%NPTRLS(MYSETW)+KGL-1 IST = 2*(G%NMEN(IGLG)+1)+1 ILEN = G%NLOEN(IGLG)+R%NNOEXTZL+3-IST IF (G%NLOEN(IGLG)>1) THEN IOFF=D%NSTAGTF(KGL)+1 IRLEN=G%NLOEN(IGLG)+R%NNOEXTZL ICLEN=(IRLEN/2+1)*2 CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) ENDIF IST1=1 IF (G%NLOEN(IGLG)==1) IST1=0 DO JJ=IST1,ILEN PREEL(1:KFIELDS,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRB ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FTDIR END MODULE FTDIR_MOD ectrans-1.8.0/src/trans/cpu/internal/vdtuvad_mod.F900000664000175000017500000001103115174631767022475 0ustar alastairalastair! (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. ! MODULE VDTUVAD_MOD CONTAINS SUBROUTINE VDTUVAD(KM,KFIELD,PEPSNM,PVOR,PDIV,PU,PV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F !**** *VDTUVAD* - Compute U,V in spectral space ! Purpose. ! -------- ! In Laplace space compute the the winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL VDTUVAD(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PVOR(NLEI1,2*KFIELD) - vorticity (input) ! PDIV(NLEI1,2*KFIELD) - divergence (input) ! PU(NLEI1,2*KFIELD) - u wind (output) ! PV(NLEI1,2*KFIELD) - v wind (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUVAD in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM,KFIELD REAL(KIND=JPRB), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(INOUT) :: PVOR(:,:),PDIV(:,:) REAL(KIND=JPRB), INTENT(IN) :: PU (:,:),PV (:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, ISMAX,JI ! LOCAL REAL SCALARS REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZN(-1:R%NTMAX+4) REAL(KIND=JPRB) :: ZLAPIN(-1:R%NSMAX+4) REAL(KIND=JPRB) :: ZEPSNM(-1:R%NSMAX+4) ! ------------------------------------------------------------------ !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ ZKM = KM ISMAX = R%NSMAX DO JN=KM-1,ISMAX+2 IJ = ISMAX+3-JN ZN(IJ) = REAL(F%RN(JN),JPRB) ZLAPIN(IJ) = REAL(F%RLAPIN(JN),JPRB) IF( JN >= 0 ) ZEPSNM(IJ) = PEPSNM(JN) ENDDO ZN(0) = REAL(F%RN(ISMAX+3),JPRB) !* 1.1 U AND V (KM=0) . IF(KM == 0) THEN DO J=1,KFIELD IR = 2*J-1 DO JI=2,ISMAX+3-KM PDIV(JI-1,IR) = PDIV(JI-1,IR)+ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PV(JI,IR) PVOR(JI-1,IR) = PVOR(JI-1,IR)-ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PU(JI,IR) PDIV(JI+1,IR) = PDIV(JI+1,IR)-ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PV(JI,IR) PVOR(JI+1,IR) = PVOR(JI+1,IR)+ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PU(JI,IR) ENDDO ENDDO !* 1.2 U AND V (KM!=0) . ELSE DO J=1,KFIELD IR = 2*J-1 II = IR+1 DO JI=2,ISMAX+3-KM PDIV(JI-1,II) = PDIV(JI-1,II)+ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PV(JI,II) PDIV(JI-1,IR) = PDIV(JI-1,IR)+ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PV(JI,IR) PVOR(JI-1,II) = PVOR(JI-1,II)-ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PU(JI,II) PVOR(JI-1,IR) = PVOR(JI-1,IR)-ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PU(JI,IR) PDIV(JI+1,II) = PDIV(JI+1,II)-ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PV(JI,II) PDIV(JI+1,IR) = PDIV(JI+1,IR)-ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PV(JI,IR) PVOR(JI+1,II) = PVOR(JI+1,II)+ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PU(JI,II) PVOR(JI+1,IR) = PVOR(JI+1,IR)+ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PU(JI,IR) PVOR(JI,IR) = PVOR(JI,IR)+ZKM*ZLAPIN(JI)*PV(JI,II) PVOR(JI,II) = PVOR(JI,II)-ZKM*ZLAPIN(JI)*PV(JI,IR) PDIV(JI,IR) = PDIV(JI,IR)+ZKM*ZLAPIN(JI)*PU(JI,II) PDIV(JI,II) = PDIV(JI,II)-ZKM*ZLAPIN(JI)*PU(JI,IR) ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE VDTUVAD END MODULE VDTUVAD_MOD ectrans-1.8.0/src/trans/cpu/internal/prepsnm_mod.F900000664000175000017500000000371315174631767022514 0ustar alastairalastair! (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. ! MODULE PREPSNM_MOD CONTAINS SUBROUTINE PREPSNM(KM,KMLOC,PEPSNM) !**** *PREPSNM* - Prepare REPSNM for wavenumber KM ! Purpose. ! -------- ! Copy the REPSNM values for specific zonal wavenumber M ! to work array !** Interface. ! ---------- ! CALL PREPSNM(...) ! Explicit arguments : KM - zonal wavenumber ! ------------------- KMLOC - local zonal wavenumber ! PEPSNM - REPSNM for zonal ! wavenumber KM ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Reference. ! ---------- ! Author. ! ------- ! Lars Isaksen *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINV in IFS CY22R1 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM,KMLOC REAL(KIND=JPRB), INTENT(OUT) :: PEPSNM(0:R%NTMAX+2) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: JN ! ------------------------------------------------------------------ !* 1. COPY REPSNM. ! ------------ IF (KM > 0) THEN PEPSNM(0:KM-1) = 0.0_JPRB ENDIF DO JN=KM,R%NTMAX+2 PEPSNM(JN) = REAL(F%REPSNM(D%NPMT(KM)+KMLOC-KM+JN),JPRB) ENDDO ! ------------------------------------------------------------------ END SUBROUTINE PREPSNM END MODULE PREPSNM_MOD ectrans-1.8.0/src/trans/cpu/internal/trgl_mod.F900000664000175000017500000005602215174631767022001 0ustar alastairalastair! (C) Copyright 2025- ECMWF. ! (C) Copyright 2025- 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. ! MODULE TRGL_MOD USE PARKIND1, ONLY : JPIM IMPLICIT NONE TYPE TRGL_BUFFERS INTEGER(KIND=JPIM) :: ISENDCOUNT = -9999 INTEGER(KIND=JPIM) :: IRECVCOUNT = -9999 INTEGER(KIND=JPIM) :: INSEND = -9999 INTEGER(KIND=JPIM) :: INRECV = -9999 INTEGER(KIND=JPIM) :: IFLDS = 0 LOGICAL :: LLTRGTOL = .FALSE. LOGICAL :: LLPGPONLY = .FALSE. LOGICAL :: LLINDER = .FALSE. INTEGER(KIND=JPIM), ALLOCATABLE :: ISENDTOT (:) INTEGER(KIND=JPIM), ALLOCATABLE :: IRECVTOT (:) INTEGER(KIND=JPIM), ALLOCATABLE :: ISEND(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IRECV(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IINDEX(:) INTEGER(KIND=JPIM), ALLOCATABLE :: INDOFF(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IGPTRSEND(:,:,:) INTEGER(KIND=JPIM), ALLOCATABLE :: ISETWL(:) INTEGER(KIND=JPIM), ALLOCATABLE :: ISETVL(:) INTEGER(KIND=JPIM), ALLOCATABLE :: ISETW(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IJPOS(:,:) INTEGER(KIND=JPIM), ALLOCATABLE :: IPOSPLUS(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IFLDA(:,:) END TYPE TRGL_BUFFERS TYPE TRGL_VARS INTEGER(KIND=JPIM), ALLOCATABLE :: IUVLEVS(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IUVPARS(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IGP2PARS(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IFLDOFF(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IGPTROFF(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IGP3APARS(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IGP3ALEVS(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IGP3BPARS(:) INTEGER(KIND=JPIM), ALLOCATABLE :: IGP3BLEVS(:) LOGICAL, ALLOCATABLE :: LLUV(:) LOGICAL, ALLOCATABLE :: LLGP2(:) LOGICAL, ALLOCATABLE :: LLGP3A(:) LOGICAL, ALLOCATABLE :: LLGP3B(:) END TYPE TRGL_VARS CONTAINS SUBROUTINE ALLOCATE_BUFFERS_CST(SELF) USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC USE TPM_TRANS ,ONLY : NGPBLKS CLASS(TRGL_BUFFERS), INTENT(INOUT) :: SELF ALLOCATE (SELF%ISENDTOT (NPROC)) ALLOCATE (SELF%IRECVTOT (NPROC)) ALLOCATE (SELF%ISEND (NPROC)) ALLOCATE (SELF%IRECV (NPROC)) ALLOCATE (SELF%IINDEX(D%NLENGTF)) ALLOCATE (SELF%INDOFF(NPROC)) ALLOCATE (SELF%IGPTRSEND(2,NGPBLKS,NPRTRNS)) ALLOCATE (SELF%ISETWL(NPROC)) ALLOCATE (SELF%ISETVL(NPROC)) END SUBROUTINE ALLOCATE_BUFFERS_CST SUBROUTINE ALLOCATE_BUFFERS_SR(SELF, KF_GP) USE TPM_TRANS ,ONLY : NGPBLKS CLASS(TRGL_BUFFERS), INTENT(INOUT) :: SELF INTEGER(KIND=JPIM),INTENT(IN) :: KF_GP IF (SELF%LLTRGTOL) THEN ALLOCATE (SELF%ISETW(SELF%INSEND)) ALLOCATE (SELF%IJPOS(NGPBLKS,SELF%INSEND)) ALLOCATE (SELF%IPOSPLUS(SELF%INSEND)) ALLOCATE (SELF%IFLDA(KF_GP,SELF%INSEND)) ELSE ALLOCATE (SELF%ISETW(SELF%INRECV)) ALLOCATE (SELF%IJPOS(NGPBLKS,SELF%INRECV)) ALLOCATE (SELF%IPOSPLUS(SELF%INRECV)) ALLOCATE (SELF%IFLDA(KF_GP,SELF%INRECV)) ENDIF END SUBROUTINE ALLOCATE_BUFFERS_SR SUBROUTINE TRGL_ALLOCATE_VARS(SELF, KF_GP, KF_FS) USE TPM_TRANS ,ONLY : NGPBLKS CLASS(TRGL_VARS), INTENT(INOUT) :: SELF INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP, KF_FS ALLOCATE(SELF%IUVLEVS(KF_GP)) ALLOCATE(SELF%IUVPARS(KF_GP)) ALLOCATE(SELF%IGP2PARS(KF_GP)) ALLOCATE(SELF%IFLDOFF(KF_FS)) ALLOCATE(SELF%IGPTROFF(NGPBLKS)) ALLOCATE(SELF%LLUV(KF_GP)) ALLOCATE(SELF%LLGP2(KF_GP)) ALLOCATE(SELF%LLGP3A(KF_GP)) ALLOCATE(SELF%LLGP3B(KF_GP)) ALLOCATE(SELF%IGP3APARS(KF_GP)) ALLOCATE(SELF%IGP3ALEVS(KF_GP)) ALLOCATE(SELF%IGP3BPARS(KF_GP)) ALLOCATE(SELF%IGP3BLEVS(KF_GP)) END SUBROUTINE TRGL_ALLOCATE_VARS SUBROUTINE TRGL_ALLOCATE_HEAP_BUFFER(Z_HEAP, S1, S2) USE PARKIND1 ,ONLY : JPIM, JPRB USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS IMPLICIT NONE REAL(KIND=JPRB), INTENT(INOUT), ALLOCATABLE :: Z_HEAP(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: S1, S2 IF (ALLOCATED(Z_HEAP)) THEN IF (S1 /= UBOUND(Z_HEAP,1) .OR. S2 /= SIZE(Z_HEAP,2) ) THEN IF (LBOUND(Z_HEAP,1) /= -1) CALL ABORT_TRANS('TRGL_MOD: WRONG Z_HEAP SIZE IN TRGL_ALLOCATE_HEAP_BUFFER ') DEALLOCATE(Z_HEAP) END IF ENDIF IF (.NOT. ALLOCATED(Z_HEAP)) THEN ALLOCATE(Z_HEAP(-1:S1,S2)) ENDIF END SUBROUTINE TRGL_ALLOCATE_HEAP_BUFFER SUBROUTINE TRGL_INIT_VARS(YLVARS, KF_SCALARS_G, PGP, PGPUV, PGP3A, PGP3B, PGP2) USE PARKIND1 ,ONLY : JPIM, JPRB USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP IMPLICIT NONE TYPE(TRGL_VARS), INTENT(INOUT) :: YLVARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G REAL(KIND=JPRB),OPTIONAL :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP2(:,:,:) ! Local variables INTEGER(KIND=JPIM) :: IUVPAR,IUVLEV,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF INTEGER(KIND=JPIM) :: IOFF,IOFF1,IOFFNS,IOFFEW,J1,J2 INTEGER(KIND=JPIM) :: J ASSOCIATE(IUVLEVS=>YLVARS%IUVLEVS, IUVPARS=>YLVARS%IUVPARS, IGP2PARS=>YLVARS%IGP2PARS, & & LLUV=>YLVARS%LLUV, LLGP2=>YLVARS%LLGP2, LLGP3A=>YLVARS%LLGP3A, LLGP3B=>YLVARS%LLGP3B, & & IGP3APARS=>YLVARS%IGP3APARS, IGP3ALEVS=>YLVARS%IGP3ALEVS, IGP3BPARS=>YLVARS%IGP3BPARS, & & IGP3BLEVS=>YLVARS%IGP3BLEVS) IUVPAR=0 IUVLEV=0 IOFF1=0 IOFFNS=KF_SCALARS_G IOFFEW=2*KF_SCALARS_G LLUV(:) = .FALSE. IUVPARS(:) = -99 IUVLEVS(:) = -99 IF (PRESENT(PGPUV)) THEN IOFF=0 IUVLEV=UBOUND(PGPUV,2) IF(LVORGP) THEN IUVPAR=IUVPAR+1 DO J=1,IUVLEV IUVLEVS(IOFF+J)=J IUVPARS(IOFF+J)=IUVPAR LLUV(IOFF+J)=.TRUE. ENDDO IOFF=IOFF+IUVLEV ENDIF IF(LDIVGP) THEN IUVPAR=IUVPAR+1 DO J=1,IUVLEV IUVLEVS(IOFF+J)=J IUVPARS(IOFF+J)=IUVPAR LLUV(IOFF+J)=.TRUE. ENDDO IOFF=IOFF+IUVLEV ENDIF DO J=1,IUVLEV IUVLEVS(IOFF+J)=J IUVPARS(IOFF+J)=IUVPAR+1 IUVLEVS(IOFF+J+IUVLEV)=J IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 ENDDO IUVPAR=IUVPAR+2 LLUV(IOFF+1:IOFF+2*IUVLEV)=.TRUE. IOFF=IOFF+2*IUVLEV IOFF1=IOFF IOFFNS=IOFFNS+IOFF IOFFEW=IOFFEW+IOFF IOFF=IUVPAR*IUVLEV+KF_SCALARS_G IF(LUVDER) THEN IF(LSCDERS) IOFF=IOFF+KF_SCALARS_G DO J=1,IUVLEV IUVLEVS(IOFF+J)=J IUVPARS(IOFF+J)=IUVPAR+1 LLUV(IOFF+J)=.TRUE. IUVLEVS(IOFF+J+IUVLEV)=J IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2 LLUV(IOFF+J+IUVLEV)=.TRUE. ENDDO IUVPAR=IUVPAR+2 IOFF=IOFF+2*IUVLEV IOFFEW=IOFFEW+2*IUVLEV ENDIF ENDIF LLGP2(:)=.FALSE. IF (PRESENT(PGP2)) THEN IOFF=IOFF1 IGP2PAR=UBOUND(PGP2,2) IF(LSCDERS) IGP2PAR=IGP2PAR/3 DO J=1,IGP2PAR LLGP2(J+IOFF) = .TRUE. IGP2PARS(J+IOFF)=J ENDDO IOFF1=IOFF1+IGP2PAR IF(LSCDERS) THEN IOFF=IOFFNS DO J=1,IGP2PAR LLGP2(J+IOFF) = .TRUE. IGP2PARS(J+IOFF)=J+IGP2PAR ENDDO IOFFNS=IOFF+IGP2PAR IOFF=IOFFEW DO J=1,IGP2PAR LLGP2(J+IOFF) = .TRUE. IGP2PARS(J+IOFF)=J+2*IGP2PAR ENDDO IOFFEW=IOFF+IGP2PAR ENDIF ENDIF LLGP3A(:) = .FALSE. IF (PRESENT(PGP3A)) THEN IGP3ALEV=UBOUND(PGP3A,2) IGP3APAR=UBOUND(PGP3A,3) IF(LSCDERS) IGP3APAR=IGP3APAR/3 IOFF=IOFF1 DO J1=1,IGP3APAR DO J2=1,IGP3ALEV LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1 IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 ENDDO ENDDO IPAROFF=IGP3APAR IOFF1=IOFF1+IGP3APAR*IGP3ALEV IF(LSCDERS) THEN IOFF=IOFFNS DO J1=1,IGP3APAR DO J2=1,IGP3ALEV LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 ENDDO ENDDO IPAROFF=IPAROFF+IGP3APAR IOFFNS=IOFFNS+IGP3APAR*IGP3ALEV IOFF=IOFFEW DO J1=1,IGP3APAR DO J2=1,IGP3ALEV LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE. IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2 ENDDO ENDDO IOFFEW=IOFFEW+IGP3APAR*IGP3ALEV ENDIF ENDIF LLGP3B(:) = .FALSE. IF (PRESENT(PGP3B)) THEN IGP3BLEV=UBOUND(PGP3B,2) IGP3BPAR=UBOUND(PGP3B,3) IF(LSCDERS) IGP3BPAR=IGP3BPAR/3 IOFF=IOFF1 DO J1=1,IGP3BPAR DO J2=1,IGP3BLEV LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1 IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 ENDDO ENDDO IPAROFF=IGP3BPAR IOFF1=IOFF1+IGP3BPAR*IGP3BLEV IF(LSCDERS) THEN IOFF=IOFFNS DO J1=1,IGP3BPAR DO J2=1,IGP3BLEV LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 ENDDO ENDDO IPAROFF=IPAROFF+IGP3BPAR IOFFNS=IOFFNS+IGP3BPAR*IGP3BLEV IOFF=IOFFEW DO J1=1,IGP3BPAR DO J2=1,IGP3BLEV LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE. IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2 ENDDO ENDDO IOFFEW=IOFFEW+IGP3BPAR*IGP3BLEV ENDIF ENDIF END ASSOCIATE END SUBROUTINE TRGL_INIT_VARS SUBROUTINE TRGL_INIT_OFF_VARS(YDBUFS,YLVARS,KVSET,KPTRGP,KF_GP) USE TPM_DISTR ,ONLY : MYSETV, MYSETW USE TPM_TRANS ,ONLY : NGPBLKS TYPE(TRGL_BUFFERS), INTENT(INOUT) :: YDBUFS TYPE(TRGL_VARS), INTENT(INOUT) :: YLVARS INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP !local variables INTEGER(KIND=JPIM) :: JFLD, IFIRST, ILAST,IPOS, JBLK ASSOCIATE(KGPTRSEND=>YDBUFS%IGPTRSEND, IFLDS=>YDBUFS%IFLDS, IFLDOFF=>YLVARS%IFLDOFF, & & IGPTROFF=>YLVARS%IGPTROFF, LLINDER=>YDBUFS%LLINDER) IFLDS = 0 DO JFLD=1,KF_GP IF(KVSET(JFLD) == MYSETV .OR. KVSET(JFLD) == -1) THEN IFLDS = IFLDS+1 IF(LLINDER) THEN IFLDOFF(IFLDS) = KPTRGP(JFLD) ELSE IFLDOFF(IFLDS) = JFLD ENDIF ENDIF ENDDO IPOS=0 DO JBLK=1,NGPBLKS IGPTROFF(JBLK)=IPOS IFIRST = KGPTRSEND(1,JBLK,MYSETW) IF(IFIRST > 0) THEN ILAST = KGPTRSEND(2,JBLK,MYSETW) IPOS=IPOS+ILAST-IFIRST+1 ENDIF ENDDO END ASSOCIATE END SUBROUTINE TRGL_INIT_OFF_VARS SUBROUTINE TGRL_INIT_PACKING_VARS(YDBUFS,YLVARS, KVSET, KF_GP, PCOMBUFS) USE PARKIND1 ,ONLY : JPIM, JPRB USE TPM_TRANS ,ONLY : NGPBLKS TYPE(TRGL_BUFFERS), INTENT(INOUT) :: YDBUFS TYPE(TRGL_VARS), INTENT(INOUT) :: YLVARS INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP REAL(KIND=JPRB), POINTER,INTENT(IN), OPTIONAL :: PCOMBUFS(:,:) !local variables INTEGER(KIND=JPIM) :: IFLD, IPOS, JFLD, IFIRST, ILAST, JBLK INTEGER(KIND=JPIM) :: KINRS, IV, ISETV, INRS ASSOCIATE(KGPTRSEND=>YDBUFS%IGPTRSEND, IPOSPLUS=>YDBUFS%IPOSPLUS, IJPOS=>YDBUFS%IJPOS, & & IFLDA=>YDBUFS%IFLDA, ISETW=>YDBUFS%ISETW) IF (YDBUFS%LLTRGTOL) THEN KINRS = YDBUFS%INSEND ELSE KINRS = YDBUFS%INRECV ENDIF !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(INRS, IV, ISETV, JBLK, IFIRST, ILAST, IFLD, IPOS, JFLD) DO INRS=1,KINRS IF (YDBUFS%LLTRGTOL) THEN IV=YDBUFS%ISEND(INRS) ELSE IV=YDBUFS%IRECV(INRS) ENDIF YDBUFS%ISETW(INRS)=YDBUFS%ISETWL(IV) ISETV=YDBUFS%ISETVL(IV) IFLD = 0 IPOS = 0 IPOSPLUS(INRS)=0 DO JFLD=1,KF_GP IF(KVSET(JFLD) == ISETV .OR. KVSET(JFLD) == -1 ) THEN IFLD = IFLD+1 IFLDA(IFLD,INRS)=JFLD ENDIF ENDDO DO JBLK=1,NGPBLKS IFIRST = KGPTRSEND(1,JBLK,ISETW(INRS)) IF(IFIRST > 0) THEN ILAST = KGPTRSEND(2,JBLK,ISETW(INRS)) IJPOS(JBLK,INRS)=IPOS IPOSPLUS(INRS)=IPOSPLUS(INRS)+(ILAST-IFIRST+1) IPOS=IPOS+(ILAST-IFIRST+1) ENDIF ENDDO IF (PRESENT(PCOMBUFS)) THEN PCOMBUFS(-1,INRS) = 1 PCOMBUFS(0,INRS) = IFLD ENDIF ENDDO !$OMP END PARALLEL DO END ASSOCIATE END SUBROUTINE TGRL_INIT_PACKING_VARS SUBROUTINE TGRL_COPY_ZCOMBUF(YDBUFS, YLVARS, INRS, ZCOMBUF, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2) USE PARKIND1 ,ONLY : JPIM, JPRB USE TPM_TRANS ,ONLY : NGPBLKS TYPE(TRGL_BUFFERS), INTENT(INOUT) :: YDBUFS TYPE(TRGL_VARS), INTENT(INOUT) :: YLVARS INTEGER(KIND=JPIM), INTENT(IN) :: INRS REAL(KIND=JPRB), POINTER, CONTIGUOUS, INTENT(INOUT) :: ZCOMBUF(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP2(:,:,:) !Local variables INTEGER(KIND=JPIM) :: I_FLD_START,I_FLD_END INTEGER(KIND=JPIM) :: IFIRST, ILAST INTEGER(KIND=JPIM) :: JJ,JI,JK,IFLDT, JBLK, IPOS ASSOCIATE(IUVLEVS=>YLVARS%IUVLEVS, IUVPARS=>YLVARS%IUVPARS, IGP2PARS=>YLVARS%IGP2PARS, & & LLUV=>YLVARS%LLUV, LLGP2=>YLVARS%LLGP2, LLGP3A=>YLVARS%LLGP3A, LLGP3B=>YLVARS%LLGP3B, & & IGP3APARS=>YLVARS%IGP3APARS, IGP3ALEVS=>YLVARS%IGP3ALEVS, IGP3BPARS=>YLVARS%IGP3BPARS, & & IGP3BLEVS=>YLVARS%IGP3BLEVS, KGPTRSEND =>YDBUFS%IGPTRSEND, IFLDA=>YDBUFS%IFLDA, & & IPOSPLUS=>YDBUFS%IPOSPLUS, JPOS=>YDBUFS%IJPOS, ISETW=>YDBUFS%ISETW, & & LLPGPONLY=>YDBUFS%LLPGPONLY, LLINDER=>YDBUFS%LLINDER) IPOS=IPOSPLUS(INRS) I_FLD_START = ZCOMBUF(-1,INRS) I_FLD_END = ZCOMBUF(0,INRS) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(IFLDT,IFIRST,ILAST,JK,JJ,JI,JBLK) DO JJ=I_FLD_START,I_FLD_END IFLDT=IFLDA(JJ,INRS) DO JBLK=1,NGPBLKS IFIRST = KGPTRSEND(1,JBLK,ISETW(INRS)) IF(IFIRST > 0) THEN ILAST = KGPTRSEND(2,JBLK,ISETW(INRS)) IF(LLINDER) THEN DO JK=IFIRST,ILAST JI=(JJ-I_FLD_START)*IPOS+JPOS(JBLK,INRS)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN ZCOMBUF(JI,INRS) = PGP(JK,KPTRGP(IFLDT),JBLK) ELSE PGP(JK,KPTRGP(IFLDT),JBLK) = ZCOMBUF(JI,INRS) ENDIF ENDDO ELSEIF(LLPGPONLY) THEN DO JK=IFIRST,ILAST JI=(JJ-I_FLD_START)*IPOS+JPOS(JBLK,INRS)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN ZCOMBUF(JI,INRS) = PGP(JK,IFLDT,JBLK) ELSE PGP(JK,IFLDT,JBLK) = ZCOMBUF(JI,INRS) ENDIF ENDDO ELSEIF(LLUV(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-I_FLD_START)*IPOS+JPOS(JBLK,INRS)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN ZCOMBUF(JI,INRS) = PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) ELSE PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) = ZCOMBUF(JI,INRS) ENDIF ENDDO ELSEIF(LLGP2(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-I_FLD_START)*IPOS+JPOS(JBLK,INRS)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN ZCOMBUF(JI,INRS) = PGP2(JK,IGP2PARS(IFLDT),JBLK) ELSE PGP2(JK,IGP2PARS(IFLDT),JBLK) = ZCOMBUF(JI,INRS) ENDIF ENDDO ELSEIF(LLGP3A(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-I_FLD_START)*IPOS+JPOS(JBLK,INRS)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN ZCOMBUF(JI,INRS) = PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) ELSE PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) = ZCOMBUF(JI,INRS) ENDIF ENDDO ELSEIF(LLGP3B(IFLDT)) THEN DO JK=IFIRST,ILAST JI=(JJ-I_FLD_START)*IPOS+JPOS(JBLK,INRS)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN ZCOMBUF(JI,INRS) = PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) ELSE PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) = ZCOMBUF(JI,INRS) ENDIF ENDDO ENDIF ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END ASSOCIATE END SUBROUTINE TGRL_COPY_ZCOMBUF SUBROUTINE TGRL_COPY_PGLAT(PGLAT, YDBUFS, YLVARS, PGP, PGPUV, PGP3A, PGP3B, PGP2) USE PARKIND1 ,ONLY : JPIM, JPRB, JPIB USE TPM_DISTR ,ONLY : MYSETW, MYPROC USE TPM_GEN ,ONLY : NOUT USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE TPM_TRANS ,ONLY : NGPBLKS REAL(KIND=JPRB),OPTIONAL :: PGLAT(:,:) TYPE(TRGL_BUFFERS), INTENT(INOUT) :: YDBUFS TYPE(TRGL_VARS), INTENT(INOUT) :: YLVARS REAL(KIND=JPRB),OPTIONAL :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL :: PGP2(:,:,:) !Local variables INTEGER(KIND=JPIM) :: IFIRST, ILAST, IFLD, IPOS, JBLK, JK INTEGER(KIND=JPIB) :: JFLD64 ASSOCIATE(IUVLEVS=>YLVARS%IUVLEVS,IFLDOFF=>YLVARS%IFLDOFF, IGPTROFF=>YLVARS%IGPTROFF, & & IUVPARS=>YLVARS%IUVPARS, IGP2PARS=>YLVARS%IGP2PARS, LLUV=>YLVARS%LLUV, & & LLGP2=>YLVARS%LLGP2, LLGP3A=>YLVARS%LLGP3A, LLGP3B=>YLVARS%LLGP3B, & & IGP3APARS=>YLVARS%IGP3APARS, IGP3ALEVS=>YLVARS%IGP3ALEVS, & & IGP3BPARS=>YLVARS%IGP3BPARS, IGP3BLEVS=>YLVARS%IGP3BLEVS, KINDEX=>YDBUFS%IINDEX, & & KNDOFF=>YDBUFS%INDOFF, KGPTRSEND =>YDBUFS%IGPTRSEND, IFLDS=>YDBUFS%IFLDS, & & LLPGPONLY=>YDBUFS%LLPGPONLY) #ifdef __NEC__ ! Loops inversion is still better on Aurora machines, according to CHMI. REK. !$OMP PARALLEL DO SCHEDULE(DYNAMIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) #else !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST) #endif DO JBLK=1,NGPBLKS IFIRST = KGPTRSEND(1,JBLK,MYSETW) IF(IFIRST > 0) THEN ILAST = KGPTRSEND(2,JBLK,MYSETW) ! Address PGLAT over 64 bits because its size may exceed 2 GB for big data and ! small number of tasks. IF(LLPGPONLY) THEN DO JFLD64=1,IFLDS IFLD = IFLDOFF(JFLD64) !DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN PGLAT(JFLD64,KINDEX(IPOS)) = PGP(JK,IFLD,JBLK) ELSE PGP(JK,IFLD,JBLK) = PGLAT(JFLD64,KINDEX(IPOS)) ENDIF ENDDO ENDDO ELSE DO JFLD64=1,IFLDS IFLD = IFLDOFF(JFLD64) IF(LLUV(IFLD)) THEN !DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN PGLAT(JFLD64,KINDEX(IPOS)) = PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) ELSE PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) = PGLAT(JFLD64,KINDEX(IPOS)) ENDIF ENDDO ELSEIF(LLGP2(IFLD)) THEN !DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN PGLAT(JFLD64,KINDEX(IPOS)) = PGP2(JK,IGP2PARS(IFLD),JBLK) ELSE PGP2(JK,IGP2PARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS)) ENDIF ENDDO ELSEIF(LLGP3A(IFLD)) THEN !DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN PGLAT(JFLD64,KINDEX(IPOS)) = PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK) ELSE PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS)) ENDIF ENDDO ELSEIF(LLGP3B(IFLD)) THEN !DIR$ VECTOR ALWAYS DO JK=IFIRST,ILAST IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1 IF (YDBUFS%LLTRGTOL) THEN PGLAT(JFLD64,KINDEX(IPOS)) = PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK) ELSE PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS)) ENDIF ENDDO ELSE WRITE(NOUT,*)'TRGTOL_MOD: ERROR',JFLD64,IFLD CALL ABORT_TRANS('TRGTOL_MOD: ERROR') ENDIF ENDDO ENDIF ENDIF ENDDO !$OMP END PARALLEL DO END ASSOCIATE END SUBROUTINE TGRL_COPY_PGLAT SUBROUTINE TRGL_PROLOG(KF_FS,KF_GP,KVSET,YDBUFS) USE PARKIND1 ,ONLY : JPIM USE TPM_DISTR ,ONLY : D, MYSETW, NPRTRNS, MYPROC, NPROC USE INIGPTR_MOD ,ONLY : INIGPTR USE PE2SET_MOD ,ONLY : PE2SET IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP TYPE (TRGL_BUFFERS), INTENT(INOUT) :: YDBUFS INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(KF_GP) INTEGER(KIND=JPIM) :: IGPTRRECV(NPRTRNS) INTEGER(KIND=JPIM) :: IFIRSTLAT, IGL, IGLL, ILASTLAT, IPOS, ISETA, ISETB, ISETV INTEGER(KIND=JPIM) :: JFLD, JGL, JL, ISETW, JROC, J INTEGER(KIND=JPIM) :: INDOFFX ! ------------------------------------------------------------------ !* 0. Some initializations ! -------------------- CALL INIGPTR(YDBUFS%IGPTRSEND,IGPTRRECV) INDOFFX = 0 YDBUFS%INRECV = 0 YDBUFS%INSEND = 0 DO JROC=1,NPROC CALL PE2SET(JROC,ISETA,ISETB,YDBUFS%ISETWL(JROC),YDBUFS%ISETVL(JROC)) ISETW=YDBUFS%ISETWL(JROC) ISETV=YDBUFS%ISETVL(JROC) ! Count up expected number of fields IPOS = COUNT(KVSET == ISETV .OR. KVSET == -1) IF (YDBUFS%LLTRGTOL) THEN YDBUFS%ISENDTOT(JROC) = IGPTRRECV(ISETW)*IPOS IF( JROC /= MYPROC) THEN IF(YDBUFS%ISENDTOT(JROC) > 0) THEN YDBUFS%INSEND = YDBUFS%INSEND+1 YDBUFS%ISEND(YDBUFS%INSEND)=JROC ENDIF ENDIF ELSE YDBUFS%IRECVTOT(JROC) = IGPTRRECV(ISETW)*IPOS IF(YDBUFS%IRECVTOT(JROC) > 0 .AND. MYPROC /= JROC) THEN YDBUFS%INRECV = YDBUFS%INRECV + 1 YDBUFS%IRECV(YDBUFS%INRECV)=JROC ENDIF ENDIF IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA)) ILASTLAT = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA)) IPOS = 0 DO JGL=IFIRSTLAT,ILASTLAT IGL = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA) IPOS = IPOS+D%NONL(IGL,ISETB) ENDDO IF (YDBUFS%LLTRGTOL) THEN YDBUFS%IRECVTOT(JROC) = IPOS*KF_FS IF(YDBUFS%IRECVTOT(JROC) > 0 .AND. MYPROC /= JROC) THEN YDBUFS%INRECV = YDBUFS%INRECV + 1 YDBUFS%IRECV(YDBUFS%INRECV)=JROC ENDIF ELSE YDBUFS%ISENDTOT(JROC) = IPOS*KF_FS IF( JROC /= MYPROC) THEN IF(YDBUFS%ISENDTOT(JROC) > 0) THEN YDBUFS%INSEND = YDBUFS%INSEND+1 YDBUFS%ISEND(YDBUFS%INSEND)=JROC ENDIF ENDIF ENDIF IF(IPOS > 0) THEN YDBUFS%INDOFF(JROC) = INDOFFX INDOFFX = INDOFFX+IPOS IPOS = 0 DO JGL=IFIRSTLAT,ILASTLAT IGL = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA) IGLL = JGL-D%NPTRLS(MYSETW)+1 DO JL=D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL),& &D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL)+D%NONL(IGL,ISETB)-1 IPOS = IPOS+1 YDBUFS%IINDEX(IPOS+YDBUFS%INDOFF(JROC)) = JL ENDDO ENDDO ENDIF ENDDO YDBUFS%ISENDCOUNT = MAXVAL(YDBUFS%ISENDTOT) YDBUFS%IRECVCOUNT = MAXVAL(YDBUFS%IRECVTOT) END SUBROUTINE TRGL_PROLOG END MODULE TRGL_MOD ectrans-1.8.0/src/trans/cpu/internal/read_legpol_mod.F900000664000175000017500000002171515174631767023307 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE READ_LEGPOL_MOD CONTAINS SUBROUTINE READ_LEGPOL USE PARKIND1 ,ONLY : JPIM, JPRB ,JPRD USE TPM_GEN, ONLY : NERR USE TPM_DISTR, ONLY : D, NPRTRV USE TPM_DIM, ONLY : R USE TPM_GEOMETRY, ONLY : G USE TPM_FLT, ONLY : S USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE TPM_CTL, ONLY : C USE BYTES_IO_MOD, ONLY : BYTES_IO_READ, JPBYTES_IO_SUCCESS, BYTES_IO_CLOSE, BYTES_IO_OPEN USE BUTTERFLY_ALG_MOD, ONLY : CLONE, UNPACK_BUTTERFLY_STRUCT USE SHAREDMEM_MOD, ONLY : SHAREDMEM_ASSOCIATE !**** *READ_LEGPOL * - read in Leg.Pol. and assocciated arrays from file or memory segment ! Purpose. ! -------- ! !** Interface. ! ---------- ! *CALL* *READ_LEGPOL* ! Explicit arguments : None ! -------------------- ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! ! ------- ! Mats Hamrud and Willem Deconinck *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 IMPLICIT NONE INTEGER(KIND=JPIM),PARAMETER :: JPIBUFL=4 INTEGER(KIND=JPIM) :: IRBYTES,IIBYTES,JMLOC,IPRTRV,IMLOC,IM,ILA,ILS INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IFILE,JSETV,IDUM,JGL,II,IDGLU2 INTEGER(KIND=JPIM),POINTER :: IBUF(:) REAL(KIND=JPRB) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,POINTER :: IBUFA(:) TYPE(CLONE) :: YLCLONE CHARACTER(LEN=8) :: CLABEL CHARACTER(LEN=16) :: CLABEL_16 ! ------------------------------------------------------------------ IRBYTES = 8 IIBYTES = 4 IDUM = 3141 IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_OPEN(IFILE,C%CLEGPOLFNAME,'R') ALLOCATE(IBUF(JPIBUFL)) ELSE NULLIFY(IBUF) ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF CLABEL = TRANSFER(IBUF(1:2),CLABEL) IF( S%LUSEFLT .AND. CLABEL /= 'LEGPOLBF') THEN WRITE(NERR,*) S%LUSEFLT,CLABEL CALL ABORT_TRANS('READ_LEGPOL:WRONG LABEL') ELSEIF(.NOT. S%LUSEFLT .AND. CLABEL /= 'LEGPOL ') THEN WRITE(NERR,*) S%LUSEFLT,CLABEL CALL ABORT_TRANS('READ_LEGPOL:WRONG LABEL') ENDIF IF(IBUF(3) /= R%NSMAX) CALL ABORT_TRANS('READ_LEGPOL:WRONG SPECTRAL TRUNCATION') IF(IBUF(4) /= R%NDGNH) CALL ABORT_TRANS('READ_LEGPOL:WRONG NO OF GAUSSIAN LATITUDES') IF(C%CIO_TYPE == 'file') THEN ALLOCATE(IBUFA(2*R%NDGNH)) CALL BYTES_IO_READ(IFILE,IBUFA,2*R%NDGNH*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*R%NDGNH,IBUFA,ADVANCE=.TRUE.) ENDIF II = 0 DO JGL=1,R%NDGNH II = II+1 IF(IBUFA(II) /= G%NLOEN(JGL)) THEN WRITE(NERR,*) 'WRONG NUMBER OF LONGITUDE POINTS ', JGL,G%NLOEN(JGL),IBUFA(II) CALL ABORT_TRANS('READ_LEGPOL:WRONG NLOEN') ENDIF II=II+1 IF(IBUFA(II) /= G%NMEN(JGL)) THEN WRITE(NERR,*) 'WRONG CUT-OFF WAVE NUMBER ', JGL,G%NMEN(JGL),IBUFA(II) CALL ABORT_TRANS('READ_LEGPOL:WRONG NMEN') ENDIF ENDDO IF(C%CIO_TYPE == 'file') THEN DEALLOCATE(IBUFA) ENDIF DO JMLOC=1,D%NUMP,NPRTRV ! +++++++++++++++++++++ JMLOC LOOP ++++++++++ IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ! Anti-symmetric IF( S%LUSEFLT .AND. ILA > S%ITHRESHOLD) THEN IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF IF(IBUF(1) /= IDGLU .OR. IBUF(2) /= ILA ) THEN WRITE(NERR,*) 'READ_LEGPOL ERROR ', IBUF,IDGLU,ILA CALL ABORT_TRANS('READ_LEGPOL:WRONG MATRIX SIZE') ENDIF ISIZE = IBUF(3) IF(C%CIO_TYPE == 'file') THEN ALLOCATE(YLCLONE%COMMSBUF(ISIZE)) IBYTES = ISIZE*IRBYTES CALL BYTES_IO_READ(IFILE,YLCLONE%COMMSBUF,IBYTES,IRET) CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,YLCLONE) DEALLOCATE(YLCLONE%COMMSBUF) ELSE CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,YDMEMBUF=C%STORAGE) ENDIF ELSE IF(C%CIO_TYPE == 'file') THEN ISIZE = IDGLU*ILA ALLOCATE(ZBUF(ISIZE)) IBYTES = ISIZE*IRBYTES CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(IMLOC)%RPNMA(IDGLU,ILA)) S%FA(IMLOC)%RPNMA(:,:) = RESHAPE(ZBUF,(/IDGLU,ILA/)) DEALLOCATE(ZBUF) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,IDGLU,ILA,S%FA(IMLOC)%RPNMA,ADVANCE=.TRUE.) ENDIF ENDIF ! Symmetric IF( S%LUSEFLT .AND. ILS > S%ITHRESHOLD) THEN IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF IF(IBUF(1) /= IDGLU .OR. IBUF(2) /= ILS ) THEN WRITE(NERR,*) 'READ_LEGPOL ERROR ', IBUF,IDGLU,ILA CALL ABORT_TRANS('READ_LEGPOL:WRONG MATRIX ZIZE') ENDIF ISIZE = IBUF(3) IF(C%CIO_TYPE == 'file') THEN ALLOCATE(YLCLONE%COMMSBUF(ISIZE)) IBYTES = ISIZE*IRBYTES CALL BYTES_IO_READ(IFILE,YLCLONE%COMMSBUF,IBYTES,IRET) CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_S,YLCLONE) DEALLOCATE(YLCLONE%COMMSBUF) ELSE CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_S,YDMEMBUF=C%STORAGE) ENDIF ELSE IF(C%CIO_TYPE == 'file') THEN ISIZE = IDGLU*ILS IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(IMLOC)%RPNMS(IDGLU,ILS)) S%FA(IMLOC)%RPNMS(:,:) = RESHAPE(ZBUF,(/IDGLU,ILS/)) DEALLOCATE(ZBUF) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,IDGLU,ILS,S%FA(IMLOC)%RPNMS,ADVANCE=.TRUE.) ENDIF ENDIF ENDDO ENDDO ! Lat-lon grid IF(S%LDLL) THEN IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF CLABEL_16 = TRANSFER(IBUF,CLABEL_16) IF(CLABEL_16 /= 'LATLON---BEG-BEG')CALL ABORT_TRANS('READ_LEGPOL:WRONG LAT/LON LABEL') DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IDGLU2 = S%NDGNHD IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF IF(IBUF(1) /= IM .OR. IBUF(2) /= IDGLU .OR. IBUF(3) /= IDGLU2 ) THEN WRITE(NERR,*) 'READ_LEGPOL ERROR ', IBUF,IM,IDGLU,IDGLU2 CALL ABORT_TRANS('READ_LEGPOL:WRONG LAT-LON MATRIX SIZE') ENDIF IF(C%CIO_TYPE == 'file') THEN ISIZE = 2*IDGLU*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(JMLOC)%RPNMWI(2*IDGLU,2)) S%FA(JMLOC)%RPNMWI(:,:) = RESHAPE(ZBUF,(/2*IDGLU,2/)) DEALLOCATE(ZBUF) ISIZE = 2*IDGLU2*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) CALL BYTES_IO_READ(IFILE,ZBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(NERR,*) 'BYTES_IO_READ ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('READ_LEGPOL:BYTES_IO_READ FAILED') ENDIF ALLOCATE(S%FA(JMLOC)%RPNMWO(2*IDGLU2,2)) S%FA(JMLOC)%RPNMWO(:,:) = RESHAPE(ZBUF,(/2*IDGLU2,2/)) DEALLOCATE(ZBUF) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*IDGLU,2,S%FA(JMLOC)%RPNMWI,ADVANCE=.TRUE.) CALL SHAREDMEM_ASSOCIATE(C%STORAGE,2*IDGLU2,2,S%FA(JMLOC)%RPNMWO,ADVANCE=.TRUE.) ENDIF ENDDO ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_READ(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) ELSE CALL SHAREDMEM_ASSOCIATE(C%STORAGE,JPIBUFL,IBUF,ADVANCE=.TRUE.) ENDIF CLABEL_16 = TRANSFER(IBUF,CLABEL_16) IF(CLABEL_16 /= 'LEGPOL---EOF-EOF')CALL ABORT_TRANS('READ_LEGPOL:WRONG END LABEL') IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_CLOSE(IFILE) DEALLOCATE(IBUF) ENDIF END SUBROUTINE READ_LEGPOL END MODULE READ_LEGPOL_MOD ectrans-1.8.0/src/trans/cpu/internal/dist_spec_control_mod.F900000664000175000017500000003176715174631767024557 0ustar alastairalastair! (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. ! MODULE DIST_SPEC_CONTROL_MOD CONTAINS SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& & KSMAX,KSPEC2,KSPEC2MX,KSPEC2G,KPOSSP,KDIM0G,KUMPP,KALLMS,KPTRMS,KN,KSORT) !**** *DIST_SPEC_CONTROL* - Distribute global spectral array among processors ! Purpose. ! -------- ! Routine for distributing spectral array !** Interface. ! ---------- ! CALL DIST_SPEC_CONTROL(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! PSPEC(:,:) - Local spectral array ! LDIM1_IS_FLD - .TRUE. if first dimension contains the fields ! KSMAX - Spectral truncation limit ! KSPEC2 - Local number of spectral coefficients ! KSPEC2MX - Maximum local number of spectral coefficients ! KSPEC2G - Global number of spectral coefficients ! KPOSSP - Position of local waves for each task ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KUMPP - Number of spectral waves on this a-set ! KALLMS - Wave numbers for all a-set concatenated together to give all wave numbers in a-set order ! KPTRMS - Pointer to the first wave number of a given a-set in kallms array. ! KN - Number of spectral coefficients for each m wave ! KSORT(:) - Re-order fields on output ! Externals. SET2PE - compute "A and B" set from PE ! ---------- MPL.. - message passing routines ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! P.Marguinaud : 2014-10-10 ! R. El Khatib 25-Jul-2019 Optimization by vectorization, proper non-blocking comms ! and overlapp send/recv with pack/unpack ! R. El Khatib 02-Jun-2022 Optimization/Cleaning ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, MPL_WAITANY, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : MTAGDISTSP, MYSETV, MYSETW, NPRCIDS, NPRTRW, MYPROC, NPROC, NPRTRV USE SET2PE_MOD ,ONLY : SET2PE USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS IMPLICIT NONE ! See https://github.com/ecmwf-ifs/ectrans/pull/98 ! There is a problem with CONTIGUOUS keyword #ifndef CONTIG_BUGGY_COMPILER #define CONTIG_STATUS ,CONTIGUOUS #else #define CONTIG_STATUS #endif REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) CONTIG_STATUS :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KVSET(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT), CONTIGUOUS :: PSPEC(:,:) LOGICAL , INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2 INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2MX INTEGER(KIND=JPIM) , INTENT(IN) :: KSPEC2G INTEGER(KIND=JPIM) , INTENT(IN) :: KPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) , INTENT(IN) :: KDIM0G(0:) INTEGER(KIND=JPIM) , INTENT(IN) :: KUMPP(NPRTRW) INTEGER(KIND=JPIM) , INTENT(IN) :: KALLMS(KSMAX+1) INTEGER(KIND=JPIM) , INTENT(IN) :: KPTRMS(NPRTRW) INTEGER(KIND=JPIM) , INTENT(IN) :: KN(0:KSMAX) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN), TARGET :: KSORT (:) REAL(KIND=JPRB) :: ZSPEC(KSPEC2MX,COUNT(KVSET(:)==MYSETV)) REAL(KIND=JPRB), ALLOCATABLE :: ZBUF(:,:,:) INTEGER(KIND=JPIM) :: IASM0G(0:KSMAX) INTEGER(KIND=JPIM) :: JM,IFLDR,IFLD,JFLD,ITAG,ILEN(NPRTRW),JA,ISND(NPRTRV,NPRTRW), JB, IFLDOFF INTEGER(KIND=JPIM) :: IRCV,ISENDREQ(NPROC), IREQRCV(NPROC), IPROC(NPROC), JMLOC, IFLDBUF, IFLDSPG, IPOSSP INTEGER(KIND=JPIM) :: ISENT, INR, IOFFPROC(NPROC+1), IFLDLOC(KFDISTG), ILOCFLD(KFDISTG) INTEGER(KIND=JPIM), POINTER :: ISORT (:) ! ------------------------------------------------------------------ ! Compute help array for distribution IF (PRESENT (KSORT)) THEN ISORT => KSORT ELSE ALLOCATE (ISORT (KFDISTG)) DO JFLD = 1, KFDISTG ISORT (JFLD) = JFLD ENDDO ENDIF DO JA=1,NPRTRW ILEN(JA) = KPOSSP(JA+1)-KPOSSP(JA) ENDDO DO JA=1,NPRTRW DO JB=1,NPRTRV CALL SET2PE(ISND(JB,JA),0,0,JA,JB) ENDDO ENDDO ! Post receive CALL GSTATS_BARRIER(790) CALL GSTATS(812,0) IRCV=0 IOFFPROC(1)=0 IF (ILEN(MYSETW) > 0) THEN DO JA=1,NPRTRW DO JB=1,NPRTRV IF (ISND(JB,JA) /= MYPROC) THEN ! count number of fields to receive from each task: IFLDR=0 DO JFLD=1,KFDISTG IF (KFROM(JFLD)==ISND(JB,JA)) THEN IF (KVSET(JFLD)==MYSETV) THEN IFLDR = IFLDR+1 ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN ITAG=MTAGDISTSP+ISND(JB,JA) IRCV=IRCV+1 CALL MPL_RECV(ZSPEC(:,IOFFPROC(IRCV)+1:IOFFPROC(IRCV)+IFLDR),KSOURCE=NPRCIDS(ISND(JB,JA)),KTAG=ITAG,& & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQRCV(IRCV),& & CDSTRING='DIST_SPEC_CONTROL:') IPROC(IRCV)=ISND(JB,JA) IOFFPROC(IRCV+1)=IOFFPROC(IRCV)+IFLDR ENDIF ENDIF ENDDO ENDDO ENDIF CALL GSTATS(812,1) !Distribute spectral array CALL GSTATS(1804,0) IASM0G(0)=1 DO JM=1,KSMAX IASM0G(JM)=IASM0G(JM-1)+KN(JM-1) ENDDO CALL GSTATS(1804,1) ALLOCATE(ZBUF(KSPEC2MX,COUNT(KFROM(:)==MYPROC),NPRTRW)) ! The next lines ensure the large array zbuf is allocated right here and not inside an omp loop below, ! where an extra omp synchro might be needed : IF (SIZE(ZBUF) > 0) THEN ZBUF(LBOUND(ZBUF,DIM=1),LBOUND(ZBUF,DIM=2),LBOUND(ZBUF,DIM=3))=HUGE(1._JPRB) ENDIF IF (LDIM1_IS_FLD) THEN ISENT=0 DO JA=1,NPRTRW IF (ILEN(JA) > 0) THEN IFLDOFF=0 DO JB=1,NPRTRV IF (ISND(JB,JA) /= MYPROC) THEN ! Locate received fields in source array : IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KFROM(JFLD)==MYPROC) THEN IFLD = IFLD+1 IF (KVSET(JFLD)==JB) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IFLDBUF,IFLDSPG,IPOSSP) DO JFLD=1,IFLDR IFLDBUF=IFLDOFF+JFLD IFLDSPG=IFLDLOC(JFLD) DO JMLOC=1,KUMPP(JA) JM=KALLMS(KPTRMS(JA)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(JA)+1 ZBUF(IPOSSP:IPOSSP+KN(JM)-1,IFLDBUF,JA) = PSPECG(IFLDSPG,IASM0G(JM):IASM0G(JM)+KN(JM)-1) ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) CALL GSTATS(812,0) ISENT = ISENT+1 ITAG = MTAGDISTSP+MYPROC CALL MPL_SEND(ZBUF(:,IFLDOFF+1:IFLDOFF+IFLDR,JA),KDEST=NPRCIDS(ISND(JB,JA)),KTAG=ITAG,& & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISENT),& & CDSTRING='DIST_SPEC_CONTROL:') IFLDOFF=IFLDOFF+IFLDR CALL GSTATS(812,1) ENDIF ENDIF ENDDO ENDIF ENDDO ! Myself: IF (ILEN(MYSETW) > 0) THEN ! Locate received fields in target and source arrays: IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KFROM(JFLD)==MYPROC) THEN IFLD = IFLD+1 IF (KVSET(JFLD)==MYSETV) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KVSET(JFLD)==MYSETV) THEN IFLD = IFLD+1 IF (KFROM(JFLD)==MYPROC) THEN IFLDR = IFLDR+1 ILOCFLD(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IFLDBUF,IFLDSPG,IPOSSP) DO JFLD=1,IFLDR IFLDBUF=ISORT(ILOCFLD(JFLD)) IFLDSPG=IFLDLOC(JFLD) DO JMLOC=1,KUMPP(MYSETW) JM=KALLMS(KPTRMS(MYSETW)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(MYSETW)+1 PSPEC(IFLDBUF,IPOSSP:IPOSSP+KN(JM)-1) = PSPECG(IFLDSPG,IASM0G(JM):IASM0G(JM)+KN(JM)-1) ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) ENDIF ENDIF DO JA=1,IRCV CALL GSTATS(812,0) CALL MPL_WAITANY(KREQUEST=IREQRCV(1:IRCV),KINDEX=INR,CDSTRING='DIST_SPEC_CTL: WAIT FOR RECV') CALL GSTATS(812,1) ! Locate received fields in target array : IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KVSET(JFLD)==MYSETV) THEN IFLD=IFLD+1 IF (KFROM(JFLD)==IPROC(INR)) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD) DO JFLD=1,IFLDR PSPEC(ISORT(IFLDLOC(JFLD)),1:KSPEC2) = ZSPEC(1:KSPEC2,IOFFPROC(INR)+JFLD) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) ENDIF ENDDO ELSE ISENT=0 DO JA=1,NPRTRW IF (ILEN(JA) > 0) THEN IFLDOFF=0 DO JB=1,NPRTRV IF (ISND(JB,JA) /= MYPROC) THEN ! Locate received fields in source array : IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KFROM(JFLD)==MYPROC) THEN IFLD = IFLD+1 IF (KVSET(JFLD)==JB) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IFLDBUF,IFLDSPG,IPOSSP) DO JFLD=1,IFLDR IFLDBUF=IFLDOFF+JFLD IFLDSPG=IFLDLOC(JFLD) DO JMLOC=1,KUMPP(JA) JM=KALLMS(KPTRMS(JA)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(JA)+1 ZBUF(IPOSSP:IPOSSP+KN(JM)-1,IFLDBUF,JA) = PSPECG(IASM0G(JM):IASM0G(JM)+KN(JM)-1,IFLDSPG) ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) CALL GSTATS(812,0) ISENT = ISENT+1 ITAG = MTAGDISTSP+MYPROC CALL MPL_SEND(ZBUF(:,IFLDOFF+1:IFLDOFF+IFLDR,JA),KDEST=NPRCIDS(ISND(JB,JA)),KTAG=ITAG,& & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISENT),& & CDSTRING='DIST_SPEC_CONTROL:') IFLDOFF=IFLDOFF+IFLDR CALL GSTATS(812,1) ENDIF ENDIF ENDDO ENDIF ENDDO ! Myself: IF (ILEN(MYSETW) > 0) THEN ! Locate received fields in target and source arrays: IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KFROM(JFLD)==MYPROC) THEN IFLD = IFLD+1 IF (KVSET(JFLD)==MYSETV) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KVSET(JFLD)==MYSETV) THEN IFLD = IFLD+1 IF (KFROM(JFLD)==MYPROC) THEN IFLDR = IFLDR+1 ILOCFLD(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JMLOC,JM,IFLDBUF,IFLDSPG,IPOSSP) DO JFLD=1,IFLDR IFLDBUF=ISORT(ILOCFLD(JFLD)) IFLDSPG=IFLDLOC(JFLD) DO JMLOC=1,KUMPP(MYSETW) JM=KALLMS(KPTRMS(MYSETW)+JMLOC-1) IPOSSP=KDIM0G(JM)-KPOSSP(MYSETW)+1 PSPEC(IPOSSP:IPOSSP+KN(JM)-1,IFLDBUF) = PSPECG(IASM0G(JM):IASM0G(JM)+KN(JM)-1,IFLDSPG) ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) ENDIF ENDIF DO JA=1,IRCV CALL GSTATS(812,0) CALL MPL_WAITANY(KREQUEST=IREQRCV(1:IRCV),KINDEX=INR,CDSTRING='DIST_SPEC_CTL: WAIT FOR RECV') CALL GSTATS(812,1) ! Locate received fields in target array : IFLD=0 IFLDR=0 DO JFLD=1,KFDISTG IF (KVSET(JFLD)==MYSETV) THEN IFLD=IFLD+1 IF (KFROM(JFLD)==IPROC(INR)) THEN IFLDR = IFLDR+1 IFLDLOC(IFLDR)=IFLD ENDIF ENDIF ENDDO IF (IFLDR > 0) THEN CALL GSTATS(1644,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD) DO JFLD=1,IFLDR PSPEC(1:KSPEC2,ISORT(IFLDLOC(JFLD))) = ZSPEC(1:KSPEC2,IOFFPROC(INR)+JFLD) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1644,1) ENDIF ENDDO ENDIF CALL GSTATS(812,0) DO JA=1,ISENT CALL MPL_WAIT(KREQUEST=ISENDREQ(JA),CDSTRING='DIST_SPEC_CTL: WAIT FOR SEND') ENDDO CALL GSTATS(812,1) CALL GSTATS_BARRIER2(790) IF (.NOT. PRESENT (KSORT)) THEN DEALLOCATE (ISORT) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIST_SPEC_CONTROL END MODULE DIST_SPEC_CONTROL_MOD ectrans-1.8.0/src/trans/cpu/internal/ftdirad_mod.F900000664000175000017500000000462615174631767022451 0ustar alastairalastair! (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. ! MODULE FTDIRAD_MOD CONTAINS SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) !**** *FTDIRAD - Direct Fourier transform ! Purpose. Routine for Grid-point to Fourier transform - adjoint ! -------- !** Interface. ! ---------- ! CALL FTDIRAD(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELDS - number of fields ! Method. ! ------- ! Externals. FFTW - FFT routine ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TPM_FFTW ,ONLY : TW, EXEC_FFTW USE TPM_DIM ,ONLY : R IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL REAL(KIND=JPRB), INTENT(INOUT) :: PREEL(:,:) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,JJ,JF,ILOEN INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE REAL(KIND=JPRB) :: ZMUL ! ------------------------------------------------------------------ ITYPE = 1 IGLG = D%NPTRLS(MYSETW)+KGL-1 IST = 2*(G%NMEN(IGLG)+1)+1 ILOEN = G%NLOEN(IGLG)+R%NNOEXTZL ILEN = ILOEN+3-IST IOFF = D%NSTAGTF(KGL)+1 IRLEN = ILOEN ICLEN = (IRLEN/2+1)*2 DO JJ=1,ILEN DO JF=1,KFIELDS PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB ENDDO ENDDO CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) ! Change of metric (not in forward routine) ZMUL = 1.0_JPRB/ILOEN DO JJ=1,ILOEN DO JF=1,KFIELDS PREEL(JF,IOFF-1+JJ) = PREEL(JF,IOFF-1+JJ)*ZMUL ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FTDIRAD END MODULE FTDIRAD_MOD ectrans-1.8.0/src/trans/cpu/internal/updspad_mod.F900000664000175000017500000001201015174631767022456 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- 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. ! MODULE UPDSPAD_MOD CONTAINS SUBROUTINE UPDSPAD(KM,KF_UV,KF_SCALARS,POA1,POA2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) !**** *UPDSPAD* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update the spectral arrays for a fixed zonal wave-number ! from values in POA1 and POA2. !** Interface. ! ---------- ! CALL UPDSPAD(...) ! Explicit arguments : ! -------------------- ! KM - zonal wave-number ! POA1 - spectral fields for zonal wavenumber KM (basic var.) ! POA2 - spectral fields for zonal wavenumber KM (vor. div.) ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Externals. UPDSPADB - basic transfer routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 94-08-02 R. El Khatib - interface to UPDSPADB ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B USE TPM_DISTR ,ONLY : D USE UPDSPBAD_MOD ,ONLY : UPDSPBAD ! IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV,KF_SCALARS REAL(KIND=JPRB) , INTENT(OUT) :: POA1(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: POA2(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND, JN, ISE,IFLD,JFLD INTEGER(KIND=JPIM) :: IDIM1,IDIM3,J3 ! ------------------------------------------------------------------ !* 1. UPDATE FIELDS ! ------------- !* 1.1 VORTICITY AND DIVERGENCE. IST = 1 IF (KF_UV > 0) THEN IST = IST+4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV IF (KM == 0) THEN IF(PRESENT(KFLDPTRUV)) THEN DO JFLD=1,KF_UV IFLD = KFLDPTRUV(JFLD) PSPVOR(IFLD,D%NASM0(0)) = 0.0_JPRB PSPDIV(IFLD,D%NASM0(0)) = 0.0_JPRB ENDDO DO JN=0,R%NSMAX ISE = 1+JN*2+1 DO JFLD=1,KF_UV IFLD = KFLDPTRUV(JFLD) PSPDIV(IFLD,ISE) = 0.0_JPRB PSPVOR(IFLD,ISE) = 0.0_JPRB ENDDO ENDDO ELSE PSPVOR(:,D%NASM0(0)) = 0.0_JPRB PSPDIV(:,D%NASM0(0)) = 0.0_JPRB DO JN=0,R%NSMAX ISE = 1+JN*2+1 PSPDIV(:,ISE) = 0.0_JPRB PSPVOR(:,ISE) = 0.0_JPRB ENDDO ENDIF ENDIF CALL UPDSPBAD(KM,KF_UV,POA2(:,IVORS:IVORE),PSPVOR,KFLDPTRUV) CALL UPDSPBAD(KM,KF_UV,POA2(:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) ENDIF !* 1.2 SCALARS IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IEND = IST+2*KF_SCALARS-1 CALL UPDSPBAD(KM,KF_SCALARS,POA1(:,IST:IEND),PSPSCALAR,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IDIM1 = NF_SC2 IEND = IST+2*IDIM1-1 CALL UPDSPBAD(KM,IDIM1,POA1(:,IST:IEND),PSPSC2) IST=IST+2*IDIM1 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPBAD(KM,IDIM1,POA1(:,IST:IEND),PSPSC3A(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPBAD(KM,IDIM1,POA1(:,IST:IEND),PSPSC3B(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF ENDIF ENDIF ! ------------------------------------------------------------------ END SUBROUTINE UPDSPAD END MODULE UPDSPAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ftinv_ctl_mod.F900000664000175000017500000002036115174631767023016 0ustar alastairalastair! (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. ! MODULE FTINV_CTL_MOD CONTAINS SUBROUTINE FTINV_CTL(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,KVSETUV,KVSETSC,KPTRGP, & & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *FTINV_CTL - Inverse Fourier transform control ! Purpose. Control routine for Fourier to Gridpoint transform ! -------- !** Interface. ! ---------- ! CALL FTINV_CTL(..) ! Explicit arguments : ! -------------------- ! PGP - gridpoint array ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fi3elds in gridpoint space ! Method. ! ------- ! Externals. TRLTOG - transposition routine ! ---------- FOURIER_IN - copy fourier data from Fourier buffer ! FTINV - fourier transform ! FSC - Fourier space computations ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NERR ,NSTACK_MEMORY_TR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP,LATLON USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE TPM_FLT ,ONLY : S USE FOURIER_IN_MOD ,ONLY : FOURIER_IN USE FSC_MOD ,ONLY : FSC USE FTINV_MOD ,ONLY : FTINV USE TRLTOG_MOD ,ONLY : TRLTOG USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_UV INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_GP INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_FS INTEGER(KIND=JPIM) ,INTENT(IN) :: KF_OUT_LT 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) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) INTEGER(KIND=JPIM) :: IST INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: J3,JGL,IGL,IOFF,IFGP2,IFGP3A,IFGP3B,IGP3APAR,IGP3BPAR REAL(KIND=JPRB),POINTER :: ZUV(:,:) REAL(KIND=JPRB),POINTER :: ZSCALAR(:,:) REAL(KIND=JPRB),POINTER :: ZNSDERS(:,:) REAL(KIND=JPRB),POINTER :: ZEWDERS(:,:) REAL(KIND=JPRB),POINTER :: ZUVDERS(:,:) #if 0 REAL(KIND=JPRB),TARGET :: ZDUM(1,D%NLENGTF) ! Reducing stack usage here, too #else REAL(KIND=JPRB),TARGET,ALLOCATABLE :: ZDUM(:,:) ! When using this (HEAP) alloc Cray CCE 8.6.2 fails in OMP 1639 #endif REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER :: ZGTF(:,:) #if 1 ALLOCATE(ZDUM(1,D%NLENGTF)) #endif ZUV => ZDUM ZSCALAR => ZDUM ZNSDERS => ZDUM ZEWDERS => ZDUM ZUVDERS => ZDUM ! ------------------------------------------------------------------ ! 1. Copy Fourier data to local array CALL GSTATS(107,0) IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ! Now, force the OS to allocate this shared array right now, not when it starts ! to be used which is an OPEN-MP loop, that would cause a threads synchronization lock : IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN ZGTF_HEAP(1,1)=HUGE(1._JPRB) ENDIF ZGTF => ZGTF_HEAP(:,:) ENDIF IF (KF_UV > 0 .OR. KF_SCDERS > 0 .OR. (LATLON.AND.S%LDLL) ) THEN IST = 1 IF (LVORGP) THEN IST = IST+KF_UV ENDIF IF (LDIVGP) THEN IST = IST+KF_UV ENDIF IF (KF_UV>0) ZUV => ZGTF(IST:IST+2*KF_UV-1,:) IST = IST+2*KF_UV IF (KF_SCALARS>0) ZSCALAR => ZGTF(IST:IST+KF_SCALARS-1,:) IST = IST+KF_SCALARS IF (KF_SCDERS>0) ZNSDERS => ZGTF(IST:IST+KF_SCDERS-1,:) IST = IST+KF_SCDERS IF (LUVDER) THEN ZUVDERS => ZGTF(IST:IST+2*KF_UV-1,:) IST = IST+2*KF_UV ENDIF IF (KF_SCDERS > 0) THEN ZEWDERS => ZGTF(IST:IST+KF_SCDERS-1,:) ENDIF ENDIF CALL GSTATS(1639,0) ! Loop over latitudes !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,IGL) DO JGL = 1, D%NDGL_FS IGL = JGL CALL FOURIER_IN(ZGTF,KF_OUT_LT,IGL) ! 2. Fourier space computations IF (KF_UV > 0 .OR. KF_SCDERS > 0 .OR. (LATLON.AND.S%LDLL) ) THEN CALL FSC(IGL,KF_UV,KF_SCALARS,KF_SCDERS,& & ZUV,ZSCALAR,ZNSDERS,ZEWDERS,ZUVDERS) ENDIF ! 3. Fourier transform IF (KF_FS > 0) THEN CALL FTINV(ZGTF,KF_FS,IGL) ! Watch out failures here (Cray CCE 8.6.2 ? Intel 18.0.1 ?) ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1639,1) NULLIFY(ZUV) NULLIFY(ZSCALAR) NULLIFY(ZNSDERS) NULLIFY(ZUVDERS) NULLIFY(ZEWDERS) #if 1 DEALLOCATE(ZDUM) #endif CALL GSTATS(107,1) ! 4. Transposition IF (PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:)=-1 IF (PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF (PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF (PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) IGP3APAR=UBOUND(PGP3A,3) IF (LSCDERS) IGP3APAR=IGP3APAR/3 DO J3=1,IGP3APAR IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF (PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) IGP3BPAR=UBOUND(PGP3B,3) IF (LSCDERS) IGP3BPAR=IGP3BPAR/3 DO J3=1,IGP3BPAR IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF IF (IOFF > 0 .AND. IOFF /= KF_SCALARS_G ) THEN WRITE(NERR,*)'FTINV:IOFF,KF_SCALARS_G ',IOFF,KF_SCALARS_G CALL ABORT_TRANS('FTINV_CTL_MOD:IOFF /= KF_SCALARS_G') ENDIF ENDIF IST = 1 IF (KF_UV_G > 0) THEN IF (LVORGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF ( LDIVGP) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF (KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G IF (LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF IF (KF_UV_G > 0 .AND. LUVDER) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF (KF_SCALARS_G > 0) THEN IF (LSCDERS) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF ENDIF CALL GSTATS(157,0) CALL TRLTOG(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& &PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(157,1) ! ------------------------------------------------------------------ !DEALLOCATE(ZGTF) END SUBROUTINE FTINV_CTL END MODULE FTINV_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/tpm_trans.F900000664000175000017500000000454115174631767022200 0ustar alastairalastair! (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. ! MODULE TPM_TRANS ! Module to contain variables "local" to a specific call to a transform ! USE PARKIND1 ,ONLY : JPIM, JPRB IMPLICIT NONE SAVE !INTEGER_M :: NF_UV ! Number of u-v fields (spectral/fourier space) !INTEGER_M :: NF_SCALARS ! Number of scalar fields (spectral/fourier space) !INTEGER_M :: NF_SCDERS ! Number of fields for derivatives of scalars ! (inverse transform, spectral/fourier space) !INTEGER_M :: NF_OUT_LT ! Number of fields that comes out of Inverse ! Legendre transform INTEGER(KIND=JPIM) :: NF_SC2 ! Number of fields in "SPSC2" arrays. INTEGER(KIND=JPIM) :: NF_SC3A ! Number of fields in "SPSC3A" arrays. INTEGER(KIND=JPIM) :: NF_SC3B ! Number of fields in "SPSC3B" arrays. !LOGICAL :: LUV ! uv fields requested !LOGICAL :: LSCALAR ! scalar fields requested LOGICAL :: LVORGP ! vorticity requested LOGICAL :: LDIVGP ! divergence requested LOGICAL :: LUVDER ! E-W derivatives of U and V requested LOGICAL :: LSCDERS ! derivatives of scalar variables are req. LOGICAL :: LATLON ! lat-lon output requested !INTEGER_M :: NLEI2 ! 8*NF_UV + 2*NF_SCALARS + 2*NF_SCDERS (dimension in ! inverse Legendre transform) !INTEGER_M :: NLED2 ! 2*NF_FS (dimension in direct Legendre transform) !INTEGER_M :: NF_FS ! Total number of fields in Fourier space !INTEGER_M :: NF_GP ! Total number of field in grid-point space !INTEGER_M :: NF_UV_G ! Global version of NF_UV (grid-point space) !INTEGER_M :: NF_SCALARS_G ! Global version of NF_SCALARS (grid-point space) REAL(KIND=JPRB), ALLOCATABLE :: FOUBUF_IN(:) ! Fourier buffer REAL(KIND=JPRB), ALLOCATABLE :: FOUBUF(:) ! Fourier buffer INTEGER(KIND=JPIM) :: NPROMA ! Blocking factor for gridpoint input/output INTEGER(KIND=JPIM) :: NGPBLKS ! Number of NPROMA blocks LOGICAL :: LGPNORM = .FALSE. ! indicates whether transform is being done for gpnorm END MODULE TPM_TRANS ectrans-1.8.0/src/trans/cpu/internal/prfi2_mod.F900000664000175000017500000000611215174631767022046 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE PRFI2_MOD CONTAINS SUBROUTINE PRFI2(KM,KMLOC,KF_FS,PAIA,PSIA) !**** *PRFI2* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *PRFI2(..) ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAIA - antisymmetric part of Fourier ! components for KM (output) ! PSIA - symmetric part of Fourier ! components for KM (output) ! Implicit arguments : The Grid point arrays of the model. ! -------------------- ! Method. ! ------- ! Externals. PRFI2B - basic copying routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-25 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 93-03-19 D. Giard - CDCONF='T' ! Modified : 93-??-?? ???????? - CDCONF='C'--> bug if CDCONF='T' ! Modified : 93-05-13 D. Giard - correction of the previous bug ! Modified : 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE PRFI2B_MOD ,ONLY : PRFI2B ! IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM) , INTENT(IN) :: KM INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC INTEGER(KIND=JPIM) , INTENT(IN) :: KF_FS REAL(KIND=JPRB) , INTENT(OUT) :: PSIA(:,:), PAIA(:,:) ! LOCAL INTEGER SCALARS ! ------------------------------------------------------------------ !* 2. EXTRACT SYM./ANTISYM. FIELDS FROM TIME T+1. ! ------------------------------------------- CALL PRFI2B(KF_FS,KM,KMLOC,PAIA,PSIA) ! ------------------------------------------------------------------ END SUBROUTINE PRFI2 END MODULE PRFI2_MOD ectrans-1.8.0/src/trans/cpu/internal/prfi2bad_mod.F900000664000175000017500000000570515174631767022524 0ustar alastairalastair! (C) Copyright 1990- ECMWF. ! (C) Copyright 1990- 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. ! MODULE PRFI2BAD_MOD CONTAINS SUBROUTINE PRFI2BAD(KFIELD,KM,KMLOC,PAIA,PSIA) !**** *PRFI2BAD* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *PRFI2BAD(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM ! Implicit arguments : FOUBUF in TPM_TRANS ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 90-07-01 ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD,KM,KMLOC REAL(KIND=JPRB) , INTENT(IN) :: PSIA(:,:), PAIA(:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IGLS, ISL, ISTAN, ISTAS, JF, JGL ! ------------------------------------------------------------------ !* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. ! ------------------------------------------------ ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) DO JGL=ISL,R%NDGNH IGLS = R%NDGL+1-JGL ISTAN = (D%NSTAGT1B(D%NPROCL(JGL) )+D%NPNTGTB1(KMLOC,JGL ))*2*KFIELD ISTAS = (D%NSTAGT1B(D%NPROCL(IGLS))+D%NPNTGTB1(KMLOC,IGLS))*2*KFIELD !DIR$ IVDEP !OCL NOVREC DO JF=1,KFIELD*2 FOUBUF(ISTAN+JF) = PSIA(JF,JGL)+PAIA(JF,JGL) FOUBUF(ISTAS+JF) = PSIA(JF,JGL)-PAIA(JF,JGL) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE PRFI2BAD END MODULE PRFI2BAD_MOD ectrans-1.8.0/src/trans/cpu/internal/trgtol_mod.F900000664000175000017500000002610615174631767022344 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE TRGTOL_MOD IMPLICIT NONE PUBLIC TRGTOL PRIVATE TRGTOL_COMM CONTAINS SUBROUTINE TRGTOL(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2) !**** *TRGTOL * - head routine for transposition of grid point data from column ! structure to latitudinal. Reorganize data between ! grid point calculations and direct Fourier Transform !** Interface. ! ---------- ! *call* *trgtol_prolog(...) ! Explicit arguments : ! -------------------- ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! R. El Khatib *Meteo-France* ! Modifications. ! -------------- ! Original : 18-Aug-2014 from trgtol ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DISTR ,ONLY : D USE TRGL_MOD, ONLY: TRGL_BUFFERS, ALLOCATE_BUFFERS_CST, TRGL_PROLOG, ALLOCATE_BUFFERS_SR IMPLICIT NONE REAL(KIND=JPRB),INTENT(OUT) :: PGLAT(KF_FS,D%NLENGTF) INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(KF_GP) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) 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(:,:,:) TYPE (TRGL_BUFFERS) :: YDBUFS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('TRGTOL',0,ZHOOK_HANDLE) YDBUFS%LLTRGTOL = .TRUE. CALL ALLOCATE_BUFFERS_CST(YDBUFS) CALL GSTATS(1805, 0) CALL TRGL_PROLOG(KF_FS, KF_GP, KVSET, YDBUFS) CALL GSTATS(1805, 1) CALL ALLOCATE_BUFFERS_SR(YDBUFS, KF_GP) CALL TRGTOL_COMM(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2, & & YDBUFS) IF (LHOOK) CALL DR_HOOK('TRGTOL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRGTOL SUBROUTINE TRGTOL_COMM(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, & & PGP2,YDBUFS) !**** *TRGTOL_COMM * - transposition of grid point data from column ! structure to latitudinal. Reorganize data between ! grid point calculations and direct Fourier Transform ! Purpose. ! -------- !** Interface. ! ---------- ! *call* *trgtol(...) ! Explicit arguments : ! -------------------- ! PGLAT - Latitudinal data ready for direct FFT (output) ! PGP - Blocked grid point data (input) ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original: 95-10-01 ! D.Dent : 97-08-04 Reorganisation to allow ! NPRTRV to differ from NPRGPEW ! : 98-06-17 add mailbox control logic (from TRLTOM) ! =99-03-29= Mats Hamrud and Deborah Salmond ! JUMP in FFT's changed to 1 ! KINDEX introduced and PCOMBUF not used for same PE ! 01-11-23 Deborah Salmond and John Hague ! LIMP_NOOLAP Option for non-overlapping message passing ! and buffer packing ! 01-12-18 Peter Towers ! Improved vector performance of GTOL_PACK,GTOL_UNPACK ! 03-04-02 G. Radnoti: call barrier always when nproc>1 ! 08-01-01 G.Mozdzynski: cleanup ! 09-01-02 G.Mozdzynski: use non-blocking recv and send ! R. El Khatib 09-Sep-2020 64 bits addressing for PGLAT ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY, & & JP_BLOCKING_STANDARD, MPL_BARRIER, JP_BLOCKING_BUFFERED USE TPM_GEN ,ONLY : NTRANS_SYNC_LEVEL, NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D, MTAGGL, NPRCIDS, MYPROC, NPROC USE TPM_TRANS ,ONLY : LGPNORM USE TRGL_MOD, ONLY: TRGL_BUFFERS, TRGL_VARS, TRGL_ALLOCATE_VARS, TRGL_ALLOCATE_HEAP_BUFFER, & & TRGL_INIT_VARS, TRGL_INIT_OFF_VARS, TGRL_COPY_ZCOMBUF, TGRL_COPY_PGLAT, & & TGRL_INIT_PACKING_VARS IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP REAL(KIND=JPRB),INTENT(OUT) :: PGLAT(KF_FS,D%NLENGTF) INTEGER(KIND=JPIM),INTENT(IN) :: KVSET(KF_GP) INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) 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(:,:,:) TYPE(TRGL_BUFFERS), INTENT(INOUT), TARGET :: YDBUFS ! LOCAL VARIABLES TYPE(TRGL_VARS) :: YLVARS INTEGER(KIND=JPIM) :: IREQ_SEND(NPROC) INTEGER(KIND=JPIM) :: IREQ_RECV(NPROC) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IRECV INTEGER(KIND=JPIM) :: ISEND, ITAG, JL, JFLD, INS, INR, JNR INTEGER(KIND=JPIM) :: II,ILEN INTEGER(KIND=JPIM) :: IRECV_FLD_START,IRECV_FLD_END ! LOCAL ARRAYS REAL(KIND=JPRB), TARGET :: ZCOMBUFS_STACK(-1:YDBUFS%ISENDCOUNT,MERGE (YDBUFS%INSEND,0,NSTACK_MEMORY_TR/=0)) REAL(KIND=JPRB), TARGET :: ZCOMBUFR_STACK(-1:YDBUFS%IRECVCOUNT,MERGE (YDBUFS%INRECV,0,NSTACK_MEMORY_TR/=0)) REAL(KIND=JPRB), ALLOCATABLE, TARGET, SAVE :: ZCOMBUFS_HEAP(:,:) REAL(KIND=JPRB), ALLOCATABLE, TARGET, SAVE :: ZCOMBUFR_HEAP(:,:) REAL(KIND=JPRB), POINTER, CONTIGUOUS :: ZCOMBUFS(:,:) REAL(KIND=JPRB), POINTER, CONTIGUOUS :: ZCOMBUFR(:,:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR ! ------------------------------------------------------------------ !* 0. Some initializations ! -------------------- ASSOCIATE(KNSEND=>YDBUFS%INSEND, KNRECV=>YDBUFS%INRECV, KSENDTOT=>YDBUFS%ISENDTOT, & & KRECVTOT=>YDBUFS%IRECVTOT, KSEND=>YDBUFS%ISEND, KRECV=>YDBUFS%IRECV, & & KINDEX=>YDBUFS%IINDEX, KNDOFF=>YDBUFS%INDOFF) IF (NSTACK_MEMORY_TR == 0) THEN CALL TRGL_ALLOCATE_HEAP_BUFFER(ZCOMBUFS_HEAP, YDBUFS%ISENDCOUNT, YDBUFS%INSEND) CALL TRGL_ALLOCATE_HEAP_BUFFER(ZCOMBUFR_HEAP, YDBUFS%IRECVCOUNT, YDBUFS%INRECV) ! Now, force the OS to allocate this shared array right now, not when it starts to be used which ! is an OPEN-MP loop, that would cause a threads synchronization lock : IF (YDBUFS%INSEND > 0 .AND. YDBUFS%ISENDCOUNT >=-1) ZCOMBUFS_HEAP(-1,1)=HUGE(1._JPRB) ZCOMBUFS (-1:,1:) => ZCOMBUFS_HEAP ZCOMBUFR (-1:,1:) => ZCOMBUFR_HEAP ELSE ZCOMBUFS (-1:,1:) => ZCOMBUFS_STACK ZCOMBUFR (-1:,1:) => ZCOMBUFR_STACK ENDIF ITAG = MTAGGL IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',0,ZHOOK_HANDLE_BAR) CALL GSTATS_BARRIER(761) IF (LHOOK) CALL DR_HOOK('TRGTOL_BAR',1,ZHOOK_HANDLE_BAR) IF(.NOT.LGPNORM)THEN CALL GSTATS(803,0) ELSE CALL GSTATS(804,0) ENDIF IF (NTRANS_SYNC_LEVEL <= 0) THEN !...Receive loop......................................................... DO INR=1,KNRECV IRECV=KRECV(INR) CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD, KREQUEST=IREQ_RECV(INR), KTAG=ITAG, & & CDSTRING='TRGTOL_COMM: NON-BLOCKING IRECV' ) ENDDO ENDIF IF(.NOT.LGPNORM)THEN CALL GSTATS(803,1) ELSE CALL GSTATS(804,1) ENDIF CALL GSTATS(1805,0) YDBUFS%LLINDER = PRESENT(KPTRGP) YDBUFS%LLPGPONLY = PRESENT(PGP) CALL TRGL_ALLOCATE_VARS(YLVARS, KF_GP,KF_FS) CALL TRGL_INIT_VARS(YLVARS, KF_SCALARS_G, PGP, PGPUV, PGP3A, PGP3B, PGP2) CALL GSTATS(1805,1) ! Copy local contribution IF(KSENDTOT(MYPROC) > 0 )THEN CALL TRGL_INIT_OFF_VARS(YDBUFS,YLVARS,KVSET,KPTRGP,KF_GP) CALL GSTATS(1601,0) CALL TGRL_COPY_PGLAT(PGLAT, YDBUFS, YLVARS, PGP, PGPUV, PGP3A, PGP3B, PGP2) CALL GSTATS(1601,1) ENDIF ! Now overlapping buffer packing/unpacking with sends/waits ! Time as if all communications to avoid double accounting IF(.NOT.LGPNORM)THEN CALL GSTATS(803,0) ELSE CALL GSTATS(804,0) ENDIF !....Pack+send loop......................................................... CALL TGRL_INIT_PACKING_VARS(YDBUFS,YLVARS, KVSET, KF_GP, ZCOMBUFS) DO INS=1,KNSEND CALL TGRL_COPY_ZCOMBUF(YDBUFS, YLVARS, INS, ZCOMBUFS, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2) ENDDO DO INS=1,KNSEND ISEND=KSEND(INS) IF (NTRANS_SYNC_LEVEL <= 1) THEN CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD, KREQUEST=IREQ_SEND(INS), KTAG=ITAG, & & CDSTRING='TRGTOL_COMM: NON-BLOCKING ISEND') ELSE CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS), KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_BLOCKING_BUFFERED, KTAG=ITAG, & & CDSTRING='TRGTOL_COMM: BLOCKING BUFFERED BSEND') ENDIF ENDDO ! Unpack loop......................................................... DO JNR=1,KNRECV IF (NTRANS_SYNC_LEVEL <= 0) THEN CALL MPL_WAITANY(KREQUEST=IREQ_RECV(1:KNRECV), KINDEX=INR, & & CDSTRING='TRGTOL_COMM: WAIT FOR ANY RECEIVES') ELSE INR = JNR IRECV=KRECV(INR) CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_BLOCKING_STANDARD, KTAG=ITAG, CDSTRING='TRGTOL_COMM: BLOCKING RECV' ) ENDIF IRECV=KRECV(INR) ILEN = KRECVTOT(IRECV)/KF_FS IRECV_FLD_START = ZCOMBUFR(-1,INR) IRECV_FLD_END = ZCOMBUFR(0,INR) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JL,II,JFLD) DO JL=1,ILEN II = KINDEX(KNDOFF(IRECV)+JL) DO JFLD=IRECV_FLD_START,IRECV_FLD_END PGLAT(JFLD,II) = ZCOMBUFR(JL+(JFLD-IRECV_FLD_START)*ILEN,INR) ENDDO ENDDO !$OMP END PARALLEL DO ENDDO IF (NTRANS_SYNC_LEVEL <= 1) THEN IF(KNSEND > 0) THEN CALL MPL_WAIT(KREQUEST=IREQ_SEND(1:KNSEND),CDSTRING='TRGTOL_COMM: WAIT FOR ISENDS') ENDIF ENDIF IF (NTRANS_SYNC_LEVEL >= 1) THEN CALL MPL_BARRIER(CDSTRING='TRGTOL_COMM: BARRIER AT END') ENDIF IF(.NOT.LGPNORM)THEN CALL GSTATS(803,1) ELSE CALL GSTATS(804,1) ENDIF CALL GSTATS_BARRIER2(761) END ASSOCIATE END SUBROUTINE TRGTOL_COMM END MODULE TRGTOL_MOD ectrans-1.8.0/src/trans/cpu/internal/spnormc_mod.F900000664000175000017500000000501115174631767022502 0ustar alastairalastair! (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. ! MODULE SPNORMC_MOD CONTAINS SUBROUTINE SPNORMC(PSM,KFLD_G,KVSET,KMASTER,KSMAX,PGM) USE PARKIND1 ,ONLY : JPIM ,JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRV, MYPROC, NPROC USE PE2SET_MOD ,ONLY : PE2SET IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(IN) :: PSM(:,:) INTEGER(KIND=JPIM) ,INTENT(IN) :: KFLD_G INTEGER(KIND=JPIM) ,INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,INTENT(IN) :: KMASTER INTEGER(KIND=JPIM) ,INTENT(IN) :: KSMAX REAL(KIND=JPRB) ,INTENT(OUT) :: PGM(KFLD_G,0:KSMAX) REAL(KIND=JPRB) :: ZRECVBUF(SIZE(PGM)) INTEGER(KIND=JPIM) :: IFLDR(NPRTRV) INTEGER(KIND=JPIM) :: ISTOTAL,JFLD,ITAG,JROC,IMSGLEN,IRECVID INTEGER(KIND=JPIM) :: IRECVNUMP,IRECVFLD,IFLD,JMLOC,IM,IBUFLENR,IA,IB INTEGER(KIND=JPIM) :: IRECVSETA,IRECVSETB ! ------------------------------------------------------------------ ISTOTAL = SIZE(PSM) IBUFLENR = SIZE(ZRECVBUF) IFLDR(:) = 0 DO JFLD=1,KFLD_G IFLDR(KVSET(JFLD)) = IFLDR(KVSET(JFLD))+1 ENDDO ITAG = 100 IF (NPROC > 1.AND.MYPROC /= KMASTER) THEN CALL MPL_SEND(PSM(:,:),KDEST=NPRCIDS(KMASTER),KTAG=ITAG,& &CDSTRING='SPNORMC:') ENDIF IF (MYPROC == KMASTER) THEN DO JROC=1,NPROC IF (JROC == KMASTER) THEN ZRECVBUF(1:ISTOTAL) = RESHAPE(PSM,SHAPE(ZRECVBUF(1:ISTOTAL))) IRECVID = MYPROC IMSGLEN = ISTOTAL ELSE CALL MPL_RECV(ZRECVBUF(1:IBUFLENR),KTAG=ITAG,& &KFROM=IRECVID,CDSTRING='SPNORMC :') ENDIF CALL PE2SET(IRECVID,IA,IB,IRECVSETA,IRECVSETB) IRECVNUMP = D%NUMPP(IRECVSETA) IRECVFLD = IFLDR(IRECVSETB) IFLD = 0 DO JFLD=1,KFLD_G IF(KVSET(JFLD) == IRECVSETB) THEN IFLD=IFLD+1 DO JMLOC=1,IRECVNUMP IM = D%NALLMS(D%NPTRMS(IRECVSETA)-1+JMLOC) PGM(JFLD,IM) = ZRECVBUF((JMLOC-1)*IRECVFLD+IFLD) ENDDO ENDIF ENDDO ENDDO ENDIF ! Perform barrier synchronisation to guarantee all processors have ! completed communication IF( NPROC > 1 )THEN CALL MPL_BARRIER(CDSTRING='SPNORMC') ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SPNORMC END MODULE SPNORMC_MOD ectrans-1.8.0/src/trans/cpu/internal/ltinv_ctl_mod.F900000664000175000017500000001077415174631767023033 0ustar alastairalastair! (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. ! MODULE LTINV_CTL_MOD CONTAINS SUBROUTINE LTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2,& & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) !**** *LTINV_CTL* - Control routine for inverse Legandre transform. ! Purpose. ! -------- ! Control routine for the inverse LEGENDRE transform !** Interface. ! ---------- ! CALL INV_TRANS_CTL(...) ! KF_OUT_LT - number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! KFLDPTRUV(:) - field pointer array for vor./div. ! KFLDPTRSC(:) - field pointer array for PSPSCALAR ! FSPGL_PROC - external procedure to be executed in fourier space ! before transposition ! Method. ! ------- ! Externals. ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-06-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : LALLOPERM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE TPM_FLT ,ONLY : S USE LTINV_MOD ,ONLY : LTINV USE TRMTOL_MOD ,ONLY : TRMTOL IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILEI2,IDIM1 ! ------------------------------------------------------------------ CALL GSTATS(102,0) ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS IDIM1 = 2*KF_OUT_LT IBLEN = D%NLENGT0B*2*KF_OUT_LT IF (ALLOCATED(FOUBUF)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF)) THEN DEALLOCATE(FOUBUF) ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF(MAX(1,IBLEN))) ENDIF IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) FOUBUF_IN(:) = 0 ENDIF ! Following switch necessary when latlon grids are used with different increments in NS and EW direction. ! Otherwise unassigned values will appear in output. This is very likely a bug (ATLAS-149) IF (S%LDLL) THEN FOUBUF_IN(:) = 0 ENDIF IF(KF_OUT_LT > 0) THEN CALL GSTATS(1647,0) !!!WARNING!!! Duplication of code besides the FSPGL_PROC argument. ! It seems that gfortran 10 does not retain the value ! of FSPGL_PROC within the OMP region. IF( PRESENT(FSPGL_PROC) ) THEN !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL LTINV(IM,JM,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,& & PSPVOR,PSPDIV,PSPSCALAR ,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL LTINV(IM,JM,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,& & PSPVOR,PSPDIV,PSPSCALAR ,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1647,1) ENDIF CALL GSTATS(102,1) CALL GSTATS(152,0) CALL TRMTOL(FOUBUF_IN,FOUBUF,2*KF_OUT_LT) CALL GSTATS(152,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) ! ------------------------------------------------------------------ END SUBROUTINE LTINV_CTL END MODULE LTINV_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/prfi1ad_mod.F900000664000175000017500000000621715174631767022360 0ustar alastairalastair! (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. ! MODULE PRFI1AD_MOD CONTAINS SUBROUTINE PRFI1AD(KM,KF_UV,KF_SCALARS,PIA,PSPVOR,PSPDIV,PSPSCALAR,& & KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE PRFI1BAD_MOD ,ONLY : PRFI1BAD !**** *PRFI1AD* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1AD(KM,PIA,PSPVOR,PSPDIV,PSPSCALAR ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPVOR - vorticity ! PSPDIV - divergence ! PSPSCALAR - scalar variables ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1AD in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KF_UV,KF_SCALARS REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) , INTENT(IN) :: PIA(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IDIV, IFIRST, ILAST, IVOR ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! ------------------------------------ IFIRST = 1 ILAST = 4*KF_UV !* 1.1 VORTICITY AND DIVERGENCE. IF(KF_UV > 0)THEN IVOR = 1 IDIV = 2*KF_UV+1 CALL PRFI1BAD(KM,PIA(:,IVOR:IDIV-1),PSPVOR,KF_UV,KFLDPTRUV) CALL PRFI1BAD(KM,PIA(:,IDIV:ILAST) ,PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV ENDIF !* 1.2 SCALAR VARIABLES. IF(KF_SCALARS > 0)THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL PRFI1BAD(KM,PIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE PRFI1AD END MODULE PRFI1AD_MOD ectrans-1.8.0/src/trans/cpu/internal/asre1ad_mod.F900000664000175000017500000000475615174631767022360 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ASRE1AD_MOD CONTAINS SUBROUTINE ASRE1AD(KM,KMLOC,KF_OUT_LT,PAOA1,PSOA1) USE PARKIND1 ,ONLY : JPIM ,JPRB USE ASRE1BAD_MOD ,ONLY : ASRE1BAD !**** *ASRE1AD* - Recombine antisymmetric and symmetric parts - adjoint ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *ASRE1AD(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (basic ! variables and N-S derivatives) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (basic ! variables and N-S derivatives) ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ASRE1BAD - basic recombination routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1AD in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM) , INTENT(IN) :: KM INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC INTEGER(KIND=JPIM) , INTENT(IN) :: KF_OUT_LT REAL(KIND=JPRB) , INTENT(OUT) :: PSOA1(:,:), PAOA1(:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IFLDS ! ------------------------------------------------------------------ IFLDS = KF_OUT_LT CALL ASRE1BAD(IFLDS,KM,KMLOC,PAOA1,PSOA1) ! ------------------------------------------------------------------ END SUBROUTINE ASRE1AD END MODULE ASRE1AD_MOD ectrans-1.8.0/src/trans/cpu/internal/write_legpol_mod.F900000664000175000017500000001613215174631767023523 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE WRITE_LEGPOL_MOD CONTAINS SUBROUTINE WRITE_LEGPOL USE PARKIND1 ,ONLY : JPIM, JPRB USE TPM_DISTR, ONLY : D, NPRTRV USE TPM_DIM, ONLY : R USE TPM_GEOMETRY, ONLY : G USE TPM_FLT, ONLY : S USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE TPM_CTL, ONLY : C USE BUTTERFLY_ALG_MOD, ONLY : CLONE, PACK_BUTTERFLY_STRUCT USE BYTES_IO_MOD, ONLY : JPBYTES_IO_SUCCESS, BYTES_IO_CLOSE, BYTES_IO_OPEN, BYTES_IO_WRITE !**** *WRITE_LEGPOL * - write out Leg.Pol. and assocciated arrays to file ! Purpose. ! -------- ! !** Interface. ! ---------- ! *CALL* *WRITE_LEGPOL* ! Explicit arguments : None ! -------------------- ! Implicit arguments : ! -------------------- ! ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! ! ------- ! Mats Hamrud and Willem Deconinck *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 IMPLICIT NONE INTEGER(KIND=JPIM),PARAMETER :: JPIBUFL=4 INTEGER(KIND=JPIM) :: IRBYTES,IIBYTES,JMLOC,IPRTRV,IMLOC,IM,ILA,ILS,IFILE,JSETV INTEGER(KIND=JPIM) :: IDGLU,ISIZE,IBYTES,IRET,IBUF(JPIBUFL),IDUM,JGL,II INTEGER(KIND=JPIM) :: IDGLU2 TYPE(CLONE) :: YLCLONE REAL(KIND=JPRB) ,ALLOCATABLE :: ZBUF(:) INTEGER(KIND=JPIM) ,ALLOCATABLE :: IBUFA(:) ! ------------------------------------------------------------------ IRBYTES = 8 IIBYTES = 4 IDUM = 3141 IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_OPEN(IFILE,C%CLEGPOLFNAME,'W',IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_OPEN FAILED') ENDIF IF( S%LUSEFLT ) THEN IBUF(1:2) = TRANSFER('LEGPOLBF',IBUF(1:2)) ELSE IBUF(1:2) = TRANSFER('LEGPOL ',IBUF(1:2)) ENDIF IBUF(3) = R%NSMAX IBUF(4) = R%NDGNH CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_WRITE FAILED') ALLOCATE(IBUFA(2*R%NDGNH)) II = 0 DO JGL=1,R%NDGNH II = II+1 IBUFA(II) = G%NLOEN(JGL) II=II+1 IBUFA(II) = G%NMEN(JGL) ENDDO CALL BYTES_IO_WRITE(IFILE,IBUFA,2*R%NDGNH*IIBYTES,IRET) IF ( IRET < JPBYTES_IO_SUCCESS ) CALL ABORT_TRANS('WRITE_LEGPOL: BYTES_IO_WRITE FAILED') DEALLOCATE(IBUFA) DO JMLOC=1,D%NUMP,NPRTRV ! +++++++++++++++++++++ JMLOC LOOP ++++++++++ IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ! Anti-symmetric IF( S%LUSEFLT .AND. ILA > S%ITHRESHOLD) THEN CALL PACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,YLCLONE) ISIZE = SIZE(YLCLONE%COMMSBUF) IBUF(:) = (/IDGLU,ILA,ISIZE,IDUM/) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF IBYTES = ISIZE*IRBYTES CALL BYTES_IO_WRITE(IFILE,YLCLONE%COMMSBUF,IBYTES,IRET) IF(IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(YLCLONE%COMMSBUF) ELSE ISIZE = IDGLU*ILA IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(IMLOC)%RPNMA,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ENDIF ! Symmetric IF( S%LUSEFLT .AND. ILS > S%ITHRESHOLD) THEN CALL PACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_S,YLCLONE) ISIZE = SIZE(YLCLONE%COMMSBUF) IBUF(:) = (/IDGLU,ILS,ISIZE,IDUM/) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF IBYTES = ISIZE*IRBYTES CALL BYTES_IO_WRITE(IFILE,YLCLONE%COMMSBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(YLCLONE%COMMSBUF) ELSE ISIZE = IDGLU*ILS IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(IMLOC)%RPNMS,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ENDIF ENDDO ENDDO ! Lat-lon grid IF(S%LDLL) THEN IBUF(:) = TRANSFER('LATLON---BEG-BEG',IBUF(1:4)) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IDGLU2 = S%NDGNHD IBUF(:) = (/IM,IDGLU,IDGLU2,IDUM/) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IIBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF ISIZE = 2*IDGLU*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(JMLOC)%RPNMWI,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ISIZE = 2*IDGLU2*2 IBYTES = ISIZE*IRBYTES ALLOCATE(ZBUF(ISIZE)) ZBUF(:) = RESHAPE(S%FA(JMLOC)%RPNMWO,(/ISIZE/)) CALL BYTES_IO_WRITE(IFILE,ZBUF,IBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN WRITE(0,*) 'BYTES_IO_WRITE ',IFILE,' ',IBYTES,' FAILED',IRET CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF DEALLOCATE(ZBUF) ENDDO ENDIF !End marker IBUF(:) = TRANSFER('LEGPOL---EOF-EOF',IBUF(1:4)) CALL BYTES_IO_WRITE(IFILE,IBUF,JPIBUFL*IIBYTES,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_WRITE FAILED') ENDIF IF(C%CIO_TYPE == 'file') THEN CALL BYTES_IO_CLOSE(IFILE,IRET) IF( IRET < JPBYTES_IO_SUCCESS ) THEN CALL ABORT_TRANS('WRITE_LEGPOL:BYTES_IO_CLOSE FAILED') ENDIF ENDIF END SUBROUTINE WRITE_LEGPOL END MODULE WRITE_LEGPOL_MOD ectrans-1.8.0/src/trans/cpu/internal/trltog_mod.F900000664000175000017500000002617715174631767022354 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE TRLTOG_MOD IMPLICIT NONE PUBLIC TRLTOG PRIVATE TRLTOG_COMM CONTAINS SUBROUTINE TRLTOG(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2) !**** *TRLTOG * - head routine for transposition of grid point data from latitudinal ! to column structure (this takes place between inverse ! FFT and grid point calculations) ! TRLTOG is the inverse of TRGTOL !** Interface. ! ---------- ! *call* *TRLTOG(...) ! Explicit arguments : ! -------------------- ! PGLAT - Latitudinal data ready for direct FFT (input) ! PGP - Blocked grid point data (output) ! KVSET - "v-set" for each field (input) ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! R. El Khatib *Meteo-France* ! Modifications. ! -------------- ! Original : 18-Aug-2014 from trltog ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DISTR ,ONLY : D USE TRGL_MOD, ONLY: TRGL_BUFFERS, ALLOCATE_BUFFERS_CST, TRGL_PROLOG, ALLOCATE_BUFFERS_SR IMPLICIT NONE REAL(KIND=JPRB),INTENT(IN) :: PGLAT(KF_FS,D%NLENGTF) INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_GP INTEGER(KIND=JPIM),INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) TYPE(TRGL_BUFFERS) :: YDBUFS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('TRLTOG',0,ZHOOK_HANDLE) YDBUFS%LLTRGTOL = .FALSE. CALL ALLOCATE_BUFFERS_CST(YDBUFS) CALL GSTATS(1806, 0) CALL TRGL_PROLOG(KF_FS, KF_GP, KVSET, YDBUFS) CALL GSTATS(1806, 1) CALL ALLOCATE_BUFFERS_SR(YDBUFS, KF_GP) CALL TRLTOG_COMM(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2, & & YDBUFS) IF (LHOOK) CALL DR_HOOK('TRLTOG',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRLTOG SUBROUTINE TRLTOG_COMM(PGLAT, KF_FS, KF_GP, KF_SCALARS_G, KVSET, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, & & PGP2,YDBUFS) !**** *trltog * - transposition of grid point data from latitudinal ! to column structure. This takes place between inverse ! FFT and grid point calculations. ! TRLTOG_COMM is the inverse of TRGTOL ! Purpose. ! -------- !** Interface. ! ---------- ! *call* *trltog(...) ! Explicit arguments : ! -------------------- ! PGLAT - Latitudinal data ready for direct FFT (input) ! PGP - Blocked grid point data (output) ! KVSET - "v-set" for each field (input) ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! D.Dent : 97-08-04 Reorganisation to allow NPRTRV ! to differ from NPRGPEW ! =99-03-29= Mats Hamrud and Deborah Salmond ! JUMP in FFT's changed to 1 ! KINDEX introduced and PCOMBUF not used for same PE ! 01-11-23 Deborah Salmond and John Hague ! LIMP_NOOLAP Option for non-overlapping message passing ! and buffer packing ! 01-12-18 Peter Towers ! Improved vector performance of LTOG_PACK,LTOG_UNPACK ! 03-0-02 G. Radnoti: Call barrier always when nproc>1 ! 08-01-01 G.Mozdzynski: cleanup ! 09-01-02 G.Mozdzynski: use non-blocking recv and send ! R. El Khatib 09-Sep-2020 64 bits addressing for PGLAT ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY, & & JP_BLOCKING_STANDARD, MPL_BARRIER, JP_BLOCKING_BUFFERED USE TPM_GEN ,ONLY : NTRANS_SYNC_LEVEL, NSTACK_MEMORY_TR USE TPM_DISTR ,ONLY : D, MTAGLG, NPRCIDS, MYPROC, NPROC USE TRGL_MOD, ONLY: TRGL_BUFFERS, TRGL_VARS, TRGL_ALLOCATE_VARS, TRGL_ALLOCATE_HEAP_BUFFER, & & TRGL_INIT_VARS, TRGL_INIT_OFF_VARS, TGRL_COPY_ZCOMBUF, TGRL_COPY_PGLAT, & & TGRL_INIT_PACKING_VARS IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS,KF_GP REAL(KIND=JPRB),INTENT(IN) :: PGLAT(KF_FS,D%NLENGTF) INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP) INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL,INTENT(OUT) :: PGP2(:,:,:) TYPE (TRGL_BUFFERS), INTENT(INOUT), TARGET :: YDBUFS ! LOCAL VARIABLES TYPE(TRGL_VARS) :: YLVARS INTEGER(KIND=JPIM) :: IREQ_SEND(NPROC) INTEGER(KIND=JPIM) :: IREQ_RECV(NPROC) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IRECV INTEGER(KIND=JPIM) :: ISEND, ITAG, JL, JFLD, INS, INR, JNR INTEGER(KIND=JPIM) :: II,ILEN INTEGER(KIND=JPIM) :: ISEND_FLD_START,ISEND_FLD_END ! LOCAL ARRAYS REAL(KIND=JPRB), TARGET :: ZCOMBUFS_STACK(-1:YDBUFS%ISENDCOUNT,MERGE (YDBUFS%INSEND,0,NSTACK_MEMORY_TR/=0)) REAL(KIND=JPRB), TARGET :: ZCOMBUFR_STACK(-1:YDBUFS%IRECVCOUNT,MERGE (YDBUFS%INRECV,0,NSTACK_MEMORY_TR/=0)) REAL(KIND=JPRB), ALLOCATABLE, TARGET, SAVE :: ZCOMBUFS_HEAP(:,:) REAL(KIND=JPRB), ALLOCATABLE, TARGET, SAVE :: ZCOMBUFR_HEAP(:,:) REAL(KIND=JPRB), POINTER, CONTIGUOUS :: ZCOMBUFS(:,:) REAL(KIND=JPRB), POINTER, CONTIGUOUS :: ZCOMBUFR(:,:) REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR ! ------------------------------------------------------------------ !* 0. Some initializations ! -------------------- ASSOCIATE(KNSEND=>YDBUFS%INSEND, KNRECV=>YDBUFS%INRECV, KSENDTOT=>YDBUFS%ISENDTOT, & & KRECVTOT=>YDBUFS%IRECVTOT, KSEND=>YDBUFS%ISEND, KRECV=>YDBUFS%IRECV, & & KINDEX=>YDBUFS%IINDEX, KNDOFF=>YDBUFS%INDOFF) IF (NSTACK_MEMORY_TR == 0) THEN CALL TRGL_ALLOCATE_HEAP_BUFFER(ZCOMBUFS_HEAP, YDBUFS%ISENDCOUNT, YDBUFS%INSEND) CALL TRGL_ALLOCATE_HEAP_BUFFER(ZCOMBUFR_HEAP, YDBUFS%IRECVCOUNT, YDBUFS%INRECV) ! Now, force the OS to allocate this shared array right now, not when it starts to be used which is ! an OPEN-MP loop, that would cause a threads synchronization lock : IF (YDBUFS%INSEND > 0 .AND. YDBUFS%ISENDCOUNT >=-1) ZCOMBUFS_HEAP(-1,1)=HUGE(1._JPRB) ZCOMBUFS (-1:,1:) => ZCOMBUFS_HEAP ZCOMBUFR (-1:,1:) => ZCOMBUFR_HEAP ELSE ZCOMBUFS (-1:,1:) => ZCOMBUFS_STACK ZCOMBUFR (-1:,1:) => ZCOMBUFR_STACK ENDIF ITAG = MTAGLG IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',0,ZHOOK_HANDLE_BAR) CALL GSTATS_BARRIER(762) IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',1,ZHOOK_HANDLE_BAR) CALL GSTATS(805,0) IF (NTRANS_SYNC_LEVEL <= 0) THEN !...Receive loop......................................................... DO INR=1,KNRECV IRECV=KRECV(INR) CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD, KREQUEST=IREQ_RECV(INR), KTAG=ITAG, & & CDSTRING='TRLTOG_COMM: NON-BLOCKING IRECV' ) ENDDO ENDIF CALL GSTATS(805,1) CALL GSTATS(1806,0) YDBUFS%LLINDER = PRESENT(KPTRGP) YDBUFS%LLPGPONLY = PRESENT(PGP) CALL TRGL_ALLOCATE_VARS(YLVARS, KF_GP,KF_FS) CALL TRGL_INIT_VARS(YLVARS, KF_SCALARS_G, PGP, PGPUV, PGP3A, PGP3B, PGP2) CALL GSTATS(1806,1) ! Copy local contribution IF(KRECVTOT(MYPROC) > 0 )THEN CALL TRGL_INIT_OFF_VARS(YDBUFS,YLVARS,KVSET,KPTRGP,KF_GP) CALL GSTATS(1604,0) CALL TGRL_COPY_PGLAT(PGLAT, YDBUFS, YLVARS, PGP, PGPUV,PGP3A, PGP3B,PGP2) CALL GSTATS(1604,1) ENDIF ! ! loop over the number of processors we need to communicate with. ! NOT MYPROC ! ! Now overlapping buffer packing/unpacking with sends/waits ! Time as if all communications to avoid double accounting CALL GSTATS(805,0) ! Pack+send loop......................................................... ISEND_FLD_START = 1 ISEND_FLD_END = KF_FS DO INS=1,KNSEND ISEND=KSEND(INS) ILEN = KSENDTOT(ISEND)/KF_FS !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JL,II) DO JL=1,ILEN II = KINDEX(KNDOFF(ISEND)+JL) DO JFLD=ISEND_FLD_START,ISEND_FLD_END ZCOMBUFS((JFLD-ISEND_FLD_START)*ILEN+JL,INS) = PGLAT(JFLD,II) ENDDO ENDDO !$OMP END PARALLEL DO ZCOMBUFS(-1,INS) = 1 ZCOMBUFS(0,INS) = KF_FS IF (NTRANS_SYNC_LEVEL <= 1) THEN CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS), KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD, KREQUEST=IREQ_SEND(INS), KTAG=ITAG, & & CDSTRING='TRLTOG_COMM: NON-BLOCKING ISEND') ELSE CALL MPL_SEND(ZCOMBUFS(-1:KSENDTOT(ISEND),INS), KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_BLOCKING_BUFFERED, KTAG=ITAG, & & CDSTRING='TRLTOG_COMM: BLOCKING BUFFERED BSEND') ENDIF ENDDO ! Unpack loop......................................................... CALL TGRL_INIT_PACKING_VARS(YDBUFS,YLVARS, KVSET, KF_GP) DO JNR=1,KNRECV IF (NTRANS_SYNC_LEVEL <= 0) THEN CALL MPL_WAITANY(KREQUEST=IREQ_RECV(1:KNRECV), KINDEX=INR, & & CDSTRING='TRLTOG_COMM: WAIT FOR ANY RECEIVES') ELSE INR = JNR IRECV=KRECV(INR) CALL MPL_RECV(ZCOMBUFR(-1:KRECVTOT(IRECV),INR), KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_BLOCKING_STANDARD, KTAG=ITAG, CDSTRING='TRLTOG_COMM: BLOCKING RECV') ENDIF CALL TGRL_COPY_ZCOMBUF(YDBUFS, YLVARS, INR, ZCOMBUFR, KPTRGP, PGP, PGPUV, PGP3A, PGP3B, PGP2) ENDDO IF (NTRANS_SYNC_LEVEL <= 1) THEN IF(KNSEND > 0) THEN CALL MPL_WAIT(KREQUEST=IREQ_SEND(1:KNSEND),CDSTRING='TRLTOG_COMM: WAIT FOR ISENDS') ENDIF ENDIF IF (NTRANS_SYNC_LEVEL >= 1) THEN CALL MPL_BARRIER(CDSTRING='TRLTOG_COMM: BARRIER AT END') ENDIF CALL GSTATS(805,1) CALL GSTATS_BARRIER2(762) END ASSOCIATE END SUBROUTINE TRLTOG_COMM END MODULE TRLTOG_MOD ectrans-1.8.0/src/trans/cpu/internal/prfi1b_mod.F900000664000175000017500000000602615174631767022213 0ustar alastairalastair! (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. ! MODULE PRFI1B_MOD CONTAINS SUBROUTINE PRFI1B(KM,PIA,PSPEC,KFIELDS,KFLDPTR) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1B(...)* ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPEC - spectral array ! KFIELDS - number of fields ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1B in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELDS REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PIA(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF,IFLD ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- ILCM = R%NSMAX+1-KM IOFF = D%NASM0(KM) IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 IFLD = KFLDPTR(JFLD) DO J=1,ILCM INM = IOFF+(ILCM-J)*2 PIA(J+2,IR) = PSPEC(IFLD,INM ) PIA(J+2,II) = PSPEC(IFLD,INM+1) ENDDO ENDDO ELSE DO J=1,ILCM INM = IOFF+(ILCM-J)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 PIA(J+2,IR) = PSPEC(JFLD,INM ) PIA(J+2,II) = PSPEC(JFLD,INM+1) ENDDO ENDDO ENDIF DO JFLD=1,2*KFIELDS PIA(1,JFLD) = 0.0_JPRB PIA(2,JFLD) = 0.0_JPRB PIA(ILCM+3:,JFLD) = 0.0_JPRB ENDDO ! ------------------------------------------------------------------ END SUBROUTINE PRFI1B END MODULE PRFI1B_MOD ectrans-1.8.0/src/trans/cpu/internal/trltom_mod.F900000664000175000017500000001060215174631767022344 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE TRLTOM_MOD CONTAINS SUBROUTINE TRLTOM(PFBUF_IN,PFBUF,KFIELD) !**** *TRLTOM * - transposition in Fourierspace ! Purpose. ! -------- ! Transpose Fourier coefficients from partitioning ! over latitudes to partitioning over wave numbers ! This is done between inverse Legendre Transform ! and inverse FFT. ! This is the inverse routine of TRMTOL. !** Interface. ! ---------- ! *CALL* *TRLTOM(...)* ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is ! -------------------- used for both input and output. ! KFIELD - Number of fields communicated ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified : 97-06-18 G. Mozdzynski - control MPI mailbox use ! (NCOMBFLEN) for nphase.eq.1 ! Modified : 99-05-28 D.Salmond - Optimise copies. ! Modified : 00-02-02 M.Hamrud - Remove NPHASE ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message ! passing and buffer packing ! G.Mozdzynski : 08-01-01 Cleanup ! Y.Seity : 07-08-30 Add barrier synchonisation under LSYNC_TRANS ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_MYRANK, MPL_WAIT, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : D, MTAGLM, MYSETW, NPRTRW, NPROC !USE TPM_GEN ,ONLY : LSYNC_TRANS IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRB) ,INTENT(INOUT) :: PFBUF(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PFBUF_IN(:) INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) INTEGER(KIND=JPIM) :: ITAG, J, ILEN, ISTA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR2 !INTEGER(KIND=JPIM) :: IREQ ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('TRLTOM',0,ZHOOK_HANDLE) ITAG = MTAGLM DO J=1,NPRTRW ILENS(J) = D%NLTSGTB(J)*KFIELD IOFFS(J) = D%NSTAGT1B(D%MSTABF(J))*KFIELD ILENR(J) = D%NLTSFTB(J)*KFIELD IOFFR(J) = D%NSTAGT1B(J)*KFIELD ENDDO IF(NPROC > 1) THEN IF (LHOOK) CALL DR_HOOK('TRLTOM_BAR',0,ZHOOK_HANDLE_BAR) CALL GSTATS_BARRIER(763) IF (LHOOK) CALL DR_HOOK('TRLTOM_BAR',1,ZHOOK_HANDLE_BAR) CALL GSTATS(806,0) ! IF (LSYNC_TRANS) THEN ! CALL MPL_BARRIER(CDSTRING='TRLTOM:') ! ENDIF CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN,KSENDCOUNTS=ILENS,& & PRECVBUF=PFBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& & KCOMM=MPL_ALL_MS_COMM,CDSTRING='TRLTOM:') !Faster on Cray - because of peculiarity of their MPICH ! CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN,KSENDCOUNTS=ILENS,& ! & PRECVBUF=PFBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& ! & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ,& ! & KCOMM=MPL_ALL_MS_COMM,CDSTRING='TRLTOM:') ! CALL MPL_WAIT(KREQUEST=IREQ,CDSTRING='TRLTOM: WAIT') CALL GSTATS(806,1) IF (LHOOK) CALL DR_HOOK('TRLTOM_BAR2',0,ZHOOK_HANDLE_BAR2) CALL GSTATS_BARRIER2(763) IF (LHOOK) CALL DR_HOOK('TRLTOM_BAR2',1,ZHOOK_HANDLE_BAR2) ELSE ILEN = D%NLTSGTB(MYSETW)*KFIELD ISTA = D%NSTAGT1B(MYSETW)*KFIELD+1 CALL GSTATS(1607,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(J) DO J=ISTA,ISTA+ILEN-1 PFBUF(J) = PFBUF_IN(J) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1607,1) ENDIF IF (LHOOK) CALL DR_HOOK('TRLTOM',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRLTOM END MODULE TRLTOM_MOD ectrans-1.8.0/src/trans/cpu/internal/spnormd_mod.F900000664000175000017500000000311615174631767022507 0ustar alastairalastair! (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. ! MODULE SPNORMD_MOD CONTAINS SUBROUTINE SPNORMD(PSPEC,KFLD,PMET,PSM) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE REAL(KIND=JPRB) ,INTENT(IN) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PMET(0:R%NSMAX) INTEGER(KIND=JPIM) ,INTENT(IN) :: KFLD REAL(KIND=JPRB) ,INTENT(OUT) :: PSM(:,:) INTEGER(KIND=JPIM) :: JM ,JFLD ,JN ,IM ,ISP ! ------------------------------------------------------------------ CALL GSTATS(1651,0) !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JM,IM,JN,ISP,JFLD) DO JM=1,D%NUMP PSM(:,JM) = 0.0_JPRB IM = D%MYMS(JM) IF(IM == 0)THEN DO JN=0,R%NSMAX ISP = D%NASM0(0)+JN*2 DO JFLD=1,KFLD PSM(JFLD,JM) = PSM(JFLD,JM)+PMET(JN)*PSPEC(JFLD,ISP)**2 ENDDO ENDDO ELSE DO JN=IM,R%NSMAX ISP = D%NASM0(IM)+(JN-IM)*2 DO JFLD=1,KFLD PSM(JFLD,JM) = PSM(JFLD,JM)+2.0_JPRB*PMET(JN)*& &(PSPEC(JFLD,ISP)**2+PSPEC(JFLD,ISP+1)**2) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1651,1) ! ------------------------------------------------------------------ END SUBROUTINE SPNORMD END MODULE SPNORMD_MOD ectrans-1.8.0/src/trans/cpu/internal/sump_trans_mod.F900000664000175000017500000002136015174631767023221 0ustar alastairalastair! (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. ! MODULE SUMP_TRANS_MOD CONTAINS SUBROUTINE SUMP_TRANS ! Set up distributed environment for the transform package (part 2) ! Modifications : ! P.Marguinaud : 11-Sep-2012 : Fix twice allocated pointer USE PARKIND1 ,ONLY : JPIM ,JPRD USE TPM_GEN ,ONLY : NOUT, NPRINTLEV USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D, LEQ_REGIONS, MYSETW, NPRTRNS, NPRTRW, NPROC, MYPROC USE SUMPLATF_MOD ,ONLY : SUMPLATF USE SUMPLAT_MOD ,ONLY : SUMPLAT USE SUSTAONL_MOD ,ONLY : SUSTAONL USE MYSENDSET_MOD ,ONLY : MYSENDSET USE MYRECVSET_MOD ,ONLY : MYRECVSET USE EQ_REGIONS_MOD ,ONLY : MY_REGION_NS, MY_REGION_EW, & & N_REGIONS, N_REGIONS_EW, N_REGIONS_NS ! IMPLICIT NONE INTEGER(KIND=JPIM) :: JM INTEGER(KIND=JPIM) :: JGL,IGL,IPLAT,ISENDSET,IRECVSET,JML,IPOS,IM INTEGER(KIND=JPIM) :: I1,I2,I3,IAUX0,IAUX1,JA1 INTEGER(KIND=JPIM) :: IGPTOT,IMEDIAP,IRESTM,JA,JB,IOFF INTEGER(KIND=JPIM),ALLOCATABLE :: IGPTOTL(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZDUM(:) REAL(KIND=JPRD) :: ZMEDIAP LOGICAL :: LLP1,LLP2 ! ------------------------------------------------------------------ LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SUMP_TRANS ===' IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NULTPP(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NULTPP ',SIZE(D%NULTPP ),SHAPE(D%NULTPP ) ALLOCATE(D%NPTRLS(NPRTRNS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLS ',SIZE(D%NPTRLS ),SHAPE(D%NPTRLS ) ALLOCATE(D%NPROCL(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCL ',SIZE(D%NPROCL ),SHAPE(D%NPROCL ) CALL SUMPLATF(R%NDGL,NPRTRNS,MYSETW,D%NULTPP,D%NPROCL,D%NPTRLS) D%NDGL_FS = D%NULTPP(MYSETW) ! Help arrays for spectral to fourier space transposition ALLOCATE(D%NLTSGTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSGTB ',SIZE(D%NLTSGTB),SHAPE(D%NLTSGTB) ALLOCATE(D%NLTSFTB (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NLTSFTB ',SIZE(D%NLTSFTB),SHAPE(D%NLTSFTB) ALLOCATE(D%NSTAGT0B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT0B ',SIZE(D%NSTAGT0B),SHAPE(D%NSTAGT0B) ALLOCATE(D%NSTAGT1B(NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGT1B ',SIZE(D%NSTAGT1B),SHAPE(D%NSTAGT1B) ALLOCATE(D%MSTABF (NPRTRNS+1)) IF(LLP2)WRITE(NOUT,9) 'D%MSTABF ',SIZE(D%MSTABF),SHAPE(D%MSTABF) D%NLTSGTB(:) = 0 DO JGL=1,D%NDGL_FS IGL = D%NPTRLS(MYSETW)+JGL-1 DO JM=0,G%NMEN(IGL) D%NLTSGTB(D%NPROCM(JM)) = D%NLTSGTB(D%NPROCM(JM))+1 ENDDO ENDDO DO JA=1,NPRTRW IPLAT = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA)+JGL-1 DO JM=1,D%NUMP IF(IGL > R%NDGNH-G%NDGLU(D%MYMS(JM)) .AND. IGL <= R%NDGNH+G%NDGLU(D%MYMS(JM))) THEN IPLAT = IPLAT + 1 ENDIF ENDDO ENDDO D%NLTSFTB(JA) = IPLAT ENDDO DO JA=1,NPRTRW-1 ISENDSET = MYSENDSET(NPRTRW,MYSETW,JA) IRECVSET = MYRECVSET(NPRTRW,MYSETW,JA) D%MSTABF(IRECVSET) = ISENDSET ENDDO D%MSTABF(MYSETW) = MYSETW ALLOCATE(D%NPNTGTB0(0:R%NSMAX,D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB0 ',SIZE(D%NPNTGTB0 ),SHAPE(D%NPNTGTB0 ) ALLOCATE(D%NPNTGTB1(D%NUMP,R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPNTGTB1 ',SIZE(D%NPNTGTB1 ),SHAPE(D%NPNTGTB1 ) DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(MYSETW) IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JML=D%NPTRMS(JA),D%NPTRMS(JA)+D%NUMPP(JA)-1 IM = D%NALLMS(JML) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB0(IM,JGL) = IPOS IPOS = IPOS+1 ELSE D%NPNTGTB0(IM,JGL) = -99 ENDIF ENDDO ENDDO ENDDO DO JA=1,NPRTRW IPOS = 0 DO JGL=1,D%NULTPP(JA) IGL = D%NPTRLS(JA) + JGL - 1 DO JM=1,D%NUMP IM = D%MYMS(JM) IF (IM <= G%NMEN(IGL)) THEN D%NPNTGTB1(JM,IGL) = IPOS IPOS = IPOS+1 ELSE D%NPNTGTB1(JM,IGL) = -99 ENDIF ENDDO ENDDO ENDDO IAUX0 = 0 IAUX1 = 0 DO JA=1,NPRTRNS-1 I1 = MYSENDSET(NPRTRNS,MYSETW,JA) I2 = MYRECVSET(NPRTRNS,MYSETW,JA) I3 = -1 DO JA1=1,NPRTRNS-1 IF(MYSENDSET(NPRTRNS,MYSETW,JA1) == I2) I3 =MYRECVSET(NPRTRNS,MYSETW,JA1) ENDDO IAUX0 = MAX(D%NLTSFTB(I1),D%NLTSGTB(I2),IAUX0) IAUX1 = MAX(D%NLTSGTB(I2),D%NLTSFTB(I3),IAUX1) ENDDO IAUX0 = MAX(D%NLTSGTB(MYSETW),IAUX0) IAUX1 = MAX(D%NLTSGTB(MYSETW),IAUX1) DO JA=1,NPRTRNS+1 D%NSTAGT0B(JA) = (JA-1)*IAUX0 D%NSTAGT1B(JA) = (JA-1)*IAUX1 ENDDO D%NLENGT0B = IAUX0*NPRTRNS ENDIF ! GRIDPOINT SPACE ALLOCATE(D%NFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NFRSTLAT ',SIZE(D%NFRSTLAT ),SHAPE(D%NFRSTLAT ) ALLOCATE(D%NLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NLSTLAT ',SIZE(D%NLSTLAT ),SHAPE(D%NLSTLAT ) ALLOCATE(D%NPTRLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRLAT ',SIZE(D%NPTRLAT ),SHAPE(D%NPTRLAT ) ALLOCATE(D%NPTRFRSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPTRFRSTLAT',SIZE(D%NPTRFRSTLAT),SHAPE(D%NPTRFRSTLAT) ALLOCATE(D%NPTRLSTLAT(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9)'D%NPTRLSTLAT',SIZE(D%NPTRLSTLAT),SHAPE(D%NPTRLSTLAT) ALLOCATE(D%LSPLITLAT(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'D%LSPLITLAT',SIZE(D%LSPLITLAT),SHAPE(D%LSPLITLAT) ALLOCATE(D%NPROCA_GP(N_REGIONS_NS)) IF(LLP2)WRITE(NOUT,9) 'D%NPROCA_GP',SIZE(D%NPROCA_GP),SHAPE(D%NPROCA_GP) IF(.NOT.D%LWEIGHTED_DISTR) THEN ALLOCATE(ZDUM(1)) CALL SUMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT,LEQ_REGIONS,& &D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& &D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& &ZDUM,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& &IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN) ELSE CALL SUMPLAT(R%NDGL,NPROC,N_REGIONS_NS,MY_REGION_NS,D%LSPLIT,LEQ_REGIONS,& &D%NFRSTLAT,D%NLSTLAT,D%NFRSTLOFF,D%NPTRLAT,& &D%NPTRFRSTLAT,D%NPTRLSTLAT,D%NPTRFLOFF,& &D%RWEIGHT,D%LWEIGHTED_DISTR,ZMEDIAP,D%NPROCA_GP,& &IMEDIAP,IRESTM,D%LSPLITLAT,MYPROC,G%NLOEN) ENDIF D%NDGL_GP = D%NLSTLAT(MY_REGION_NS)-D%NFRSTLOFF IF (LLP1) THEN IF(.NOT.D%LGRIDONLY) THEN WRITE(NOUT,FMT='(/'' OUTPUT FROM ROUTINE SUMPLAT: ''/)') WRITE(NOUT,FMT='('' D%NULTPP '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NULTPP(1:NPRTRNS) WRITE(NOUT,FMT='('' D%NPROCL '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPROCL(1:R%NDGL) ENDIF WRITE(NOUT,FMT='('' D%NFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NFRSTLOFF D%NPTRFLOFF '')') WRITE(NOUT,FMT='(2(1X,I6))') D%NFRSTLOFF, D%NPTRFLOFF WRITE(NOUT,FMT='('' D%NPTRLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%LSPLITLAT '')') WRITE(NOUT,FMT='(50(1X,L1))') D%LSPLITLAT(1:R%NDGL) WRITE(NOUT,FMT='('' D%NPTRFRSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRFRSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='('' D%NPTRLSTLAT '')') WRITE(NOUT,FMT='(20(1X,I4))') D%NPTRLSTLAT(1:N_REGIONS_NS) WRITE(NOUT,FMT='(/)') ENDIF ALLOCATE(D%NSTA(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NSTA ',SIZE(D%NSTA ),SHAPE(D%NSTA ) ALLOCATE(D%NONL(R%NDGL+N_REGIONS_NS-1,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NONL ',SIZE(D%NONL ),SHAPE(D%NONL ) IF(.NOT.D%LWEIGHTED_DISTR) THEN CALL SUSTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,ZDUM,ZMEDIAP,D%NPROCA_GP) ELSE CALL SUSTAONL(IMEDIAP,IRESTM,D%LWEIGHTED_DISTR,D%RWEIGHT,ZMEDIAP,D%NPROCA_GP) ENDIF ! IGPTOTL is the number of grid points in each individual processor ALLOCATE(IGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IGPTOTL(:,:)=0 DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) IGPTOT = 0 DO JGL=D%NPTRFRSTLAT(JA),D%NPTRLSTLAT(JA) IGPTOT = IGPTOT+D%NONL(JGL,JB) ENDDO IGPTOTL(JA,JB) = IGPTOT ENDDO ENDDO D%NGPTOT = IGPTOTL(MY_REGION_NS,MY_REGION_EW) D%NGPTOTMX = MAXVAL(IGPTOTL) D%NGPTOTG = SUM(IGPTOTL) ALLOCATE(D%NGPTOTL(N_REGIONS_NS,N_REGIONS_EW)) IF(LLP2)WRITE(NOUT,9) 'D%NGPTOTL ',SIZE(D%NGPTOTL ),SHAPE(D%NGPTOTL ) D%NGPTOTL(:,:) = IGPTOTL(:,:) IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(D%NSTAGTF(D%NDGL_FS)) IF(LLP2)WRITE(NOUT,9) 'D%NSTAGTF ',SIZE(D%NSTAGTF ),SHAPE(D%NSTAGTF ) IOFF = 0 DO JGL=1,D%NDGL_FS D%NSTAGTF(JGL) = IOFF IGL = D%NPTRLS(MYSETW) + JGL - 1 IOFF = IOFF + G%NLOEN(IGL)+3 ENDDO D%NLENGTF = IOFF ENDIF IF(ALLOCATED(ZDUM)) DEALLOCATE(ZDUM) DEALLOCATE(IGPTOTL) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) END SUBROUTINE SUMP_TRANS END MODULE SUMP_TRANS_MOD ectrans-1.8.0/src/trans/cpu/internal/ltdirad_mod.F900000664000175000017500000001330515174631767022451 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE LTDIRAD_MOD CONTAINS SUBROUTINE LTDIRAD(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE PREPSNM_MOD ,ONLY : PREPSNM USE PRFI2AD_MOD ,ONLY : PRFI2AD USE LDFOU2_MOD ,ONLY : LDFOU2 USE LEDIRAD_MOD ,ONLY : LEDIRAD USE UVTVDAD_MOD ,ONLY : UVTVDAD USE UPDSPAD_MOD ,ONLY : UPDSPAD !**** *LTDIRAD* - Control of Direct Legendre transform step - adjoint ! Purpose. ! -------- ! Tranform from Fourier space to spectral space, compute ! vorticity and divergence. !** Interface. ! ---------- ! *CALL* *LTDIRAD(...)* ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI2AD - prepares the Fourier work arrays for model variables. ! LDFOU2 - computations in Fourier space ! LEDIRAD - direct Legendre transform ! UVTVDAD - ! UPDSPAD - updating of spectral arrays (fields) ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-11-24 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified 93-03-19 D. Giard - CDCONF='T' for tendencies ! Modified 93-11-18 M. Hamrud - use only one Fourier buffer ! Modified 94-04-06 R. El khatib Full-POS implementation ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group : 95-10-01 Support for Distributed Memory version ! K. YESSAD (AUGUST 1996): ! - Legendre transforms for transmission coefficients. ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! R. El Khatib 12-Jul-2012 LDSPC2AD replaced by UVTVDAD ! ------------------------------------------------------------------ IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM),INTENT(IN) :: KF_FS,KF_UV,KF_SCALARS,KLED2 REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IFC, IIFC, IDGLU INTEGER(KIND=JPIM) :: IUS, IUE, IVS, IVE, IVORS, IVORE, IDIVS, IDIVE ! LOCAL REALS REAL(KIND=JPRB) :: ZSIA(KLED2,R%NDGNH), ZAIA(KLED2,R%NDGNH) REAL(KIND=JPRB) :: ZEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB) :: ZOA1(R%NLED4,KLED2), ZOA2(R%NLED4,MAX(4*KF_UV,1)) ! ------------------------------------------------------------------ !* 1. PREPARE LEGENDRE POLONOMIALS AND EPSNM ! -------------------------------------- ! ------------------------------------------------------------------ !* 6. UPDATE SPECTRAL ARRAYS. ! ----------------------- CALL UPDSPAD(KM,KF_UV,KF_SCALARS,ZOA1,ZOA2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ! ------------------------------------------------------------------ !* 5. COMPUTE VORTICITY AND DIVERGENCE. ! --------------------------------- IF( KF_UV > 0 ) THEN CALL PREPSNM(KM,KMLOC,ZEPSNM) IUS = 1 IUE = 2*KF_UV IVS = 2*KF_UV+1 IVE = 4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV ! SET PART OF ZOA1 CONTAINING U AND V TO 0. ZOA1(:,IUS:IVE) = 0.0_JPRB CALL UVTVDAD(KM,KF_UV,ZEPSNM,ZOA1(:,IUS:IUE),ZOA1(:,IVS:IVE),& & ZOA2(:,IVORS:IVORE),ZOA2(:,IDIVS:IDIVE)) ENDIF ! ------------------------------------------------------------------ !* 4. DIRECT LEGENDRE TRANSFORM. ! -------------------------- IFC = 2*KF_FS IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) IIFC = IFC IF(KM == 0)THEN IIFC = IFC/2 ENDIF CALL LEDIRAD(KM,KMLOC,IFC,IIFC,IDGLU,KLED2,ZAIA,ZSIA,ZOA1) ! ------------------------------------------------------------------ !* 3. FOURIER SPACE COMPUTATIONS. ! --------------------------- CALL LDFOU2(KM,KF_UV,ZAIA,ZSIA) ! ------------------------------------------------------------------ !* 2. PREPARE WORK ARRAYS. ! -------------------- CALL PRFI2AD(KM,KMLOC,KF_FS,ZAIA,ZSIA) ! ------------------------------------------------------------------ END SUBROUTINE LTDIRAD END MODULE LTDIRAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ltinvad_mod.F900000664000175000017500000001502315174631767022466 0ustar alastairalastair! (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. ! MODULE LTINVAD_MOD CONTAINS SUBROUTINE LTINVAD(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B USE TPM_GEOMETRY ,ONLY : G !USE PRLE1AD_MOD USE PREPSNM_MOD ,ONLY : PREPSNM USE PRFI1BAD_MOD ,ONLY : PRFI1BAD USE VDTUVAD_MOD ,ONLY : VDTUVAD USE SPNSDEAD_MOD ,ONLY : SPNSDEAD USE LEINVAD_MOD ,ONLY : LEINVAD USE ASRE1BAD_MOD ,ONLY : ASRE1BAD !**** *LTINVAD* - Inverse Legendre transform ! Purpose. ! -------- ! Tranform from Laplace space to Fourier space, compute U and V ! and north/south derivatives of state variables. !** Interface. ! ---------- ! *CALL* *LTINVAD(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : The Laplace arrays of the model. ! -------------------- The values of the Legendre polynomials ! The grid point arrays of the model ! Method. ! ------- ! Externals. ! ---------- ! PRLE1AD - prepares the Legendre polonymials ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1AD - prepares the spectral fields ! VDTUVAD - compute u and v from vorticity and divergence ! SPNSDEAD- compute north-south derivatives ! LEINVAD - Inverse Legendre transform ! ASRE1AD - recombination of symmetric/antisymmetric part ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LTINVAD in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 INTEGER(KIND=JPIM), INTENT(IN) :: KDIM1 REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(INOUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) REAL(KIND=JPRB) :: ZIA(R%NLEI1,KLEI2) REAL(KIND=JPRB) :: ZEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB) :: ZSOA1(KDIM1,R%NLEI3),ZAOA1(KDIM1,R%NLEI3) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IFC, ISTA, IIFC, IDGLU INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,ISL,ISU,IDL,IDU INTEGER(KIND=JPIM) :: ILAST,IFIRST,IDIM1,IDIM3,J3 ! LOCAL LOGICAL SCALARS ! LOCAL REAL SCALARS ! ------------------------------------------------------------------ !* 1. PREPARE AND ZEPSNM. ! ------------------- CALL PREPSNM(KM,KMLOC,ZEPSNM) ! ------------------------------------------------------------------ !* 5. RECOMBINATION SYMMETRIC/ANTISYMMETRIC PART. ! -------------------------------------------- CALL ASRE1BAD(KF_OUT_LT,KM,KMLOC,ZAOA1,ZSOA1) ! ------------------------------------------------------------------ !* 4. INVERSE LEGENDRE TRANSFORM. ! --------------------------- ISTA = 1 IFC = 2*KF_OUT_LT IF(KF_UV > 0 .AND. .NOT. LVORGP) THEN ISTA = ISTA+2*KF_UV ENDIF IF(KF_UV > 0 .AND. .NOT. LDIVGP) THEN ISTA = ISTA+2*KF_UV ENDIF ZIA(:,ISTA:ISTA+IFC-1) = 0.0_JPRB IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) IIFC=IFC IF(KM == 0)THEN IIFC=IFC/2 ENDIF CALL LEINVAD(KM,KMLOC,IFC,IIFC,KF_OUT_LT,IDGLU,ZIA(:,ISTA:ISTA+IFC-1),ZAOA1,ZSOA1) ! ------------------------------------------------------------------ !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- ZIA(:,1:ISTA-1) = 0.0_JPRB IFIRST = 1 ILAST = 4*KF_UV IF (KF_UV > 0) THEN IVORL = 1 IVORU = 2*KF_UV IDIVL = 2*KF_UV+1 IDIVU = 4*KF_UV IUL = 4*KF_UV+1 IUU = 6*KF_UV IVL = 6*KF_UV+1 IVU = 8*KF_UV CALL VDTUVAD(KM,KF_UV,ZEPSNM,ZIA(:,IVORL:IVORU),ZIA(:,IDIVL:IDIVU),& & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU)) CALL PRFI1BAD(KM,ZIA(:,IVORL:IVORU),PSPVOR,KF_UV,KFLDPTRUV) CALL PRFI1BAD(KM,ZIA(:,IDIVL:IDIVU),PSPDIV,KF_UV,KFLDPTRUV) ILAST = ILAST+4*KF_UV ENDIF IF (KF_SCDERS > 0) THEN ISL = 2*(4*KF_UV)+1 ISU = ISL+2*KF_SCALARS-1 IDL = 2*(4*KF_UV+KF_SCALARS)+1 IDU = IDL+2*KF_SCDERS-1 CALL SPNSDEAD(KM,KF_SCALARS,ZEPSNM,ZIA(:,ISL:ISU),ZIA(:,IDL:IDU)) ENDIF IF(KF_SCALARS > 0)THEN IF(PRESENT(PSPSCALAR)) THEN IFIRST = ILAST+1 ILAST = IFIRST - 1 + 2*KF_SCALARS CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSCALAR(:,:),KF_SCALARS,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IFIRST = ILAST+1 ILAST = IFIRST-1+2*NF_SC2 CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSC2(:,:),NF_SC2) ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSC3A(:,:,J3),IDIM1) ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IFIRST = ILAST+1 ILAST = IFIRST-1+2*IDIM1 CALL PRFI1BAD(KM,ZIA(:,IFIRST:ILAST),PSPSC3B(:,:,J3),IDIM1) ENDDO ENDIF ENDIF ENDIF ! ------------------------------------------------------------------ END SUBROUTINE LTINVAD END MODULE LTINVAD_MOD ectrans-1.8.0/src/trans/cpu/internal/inigptr_mod.F900000664000175000017500000000526315174631767022506 0ustar alastairalastair! (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. ! MODULE INIGPTR_MOD CONTAINS SUBROUTINE INIGPTR(KGPTRSEND,KGPTRRECV) ! Compute tables to assist GP to/from Fourier space transpositions USE PARKIND1 ,ONLY : JPIM USE TPM_GEN ,ONLY : NOUT USE TPM_DISTR ,ONLY : D, NPRTRNS USE TPM_TRANS ,ONLY : NGPBLKS, NPROMA USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(OUT) :: KGPTRSEND(2,NGPBLKS,NPRTRNS) INTEGER(KIND=JPIM),INTENT(OUT) :: KGPTRRECV(NPRTRNS) INTEGER(KIND=JPIM) :: IBLOCK,IROF,IBFIRST,IPROCLAST,IPROC,IFIRST,ILAST,IBLAST INTEGER(KIND=JPIM) :: JGL,JBL,JPRTRNS,JBLKS ! Compute tables to assist GP to/from Fourier space transpositions KGPTRSEND(:,:,:)=0 IBLOCK=1 IROF=1 IBFIRST=1 IPROCLAST=D%NPROCL(D%NFRSTLOFF+1) DO JGL=1,D%NDGL_GP ! Find processor which deals with this latitude in Fourier distribution IPROC=D%NPROCL(D%NFRSTLOFF+JGL) IF(IPROC > NPRTRNS) THEN WRITE(NOUT,'(A,I8)')& &' INIGPTR ERROR : exceeding processor limit ',NPRTRNS CALL ABORT_TRANS(' INIGPTR ERROR : exceeding processor limit ') ENDIF ! for each latitude on this processor, find first and last points ! for each NPROMA chunk, for each destination processor IF(IPROC /= IPROCLAST) THEN IF(IROF > 1) THEN KGPTRSEND(1,IBLOCK,IPROCLAST)=IBFIRST KGPTRSEND(2,IBLOCK,IPROCLAST)=IROF-1 ENDIF IF(IROF <= NPROMA) IBFIRST=IROF IPROCLAST=IPROC ENDIF IFIRST=D%NSTA(D%NPTRFLOFF+JGL,MY_REGION_EW) ILAST =IFIRST + D%NONL(D%NPTRFLOFF+JGL,MY_REGION_EW) -1 DO JBL=IFIRST,ILAST IF(IROF == NPROMA) THEN IBLAST=IROF KGPTRSEND(1,IBLOCK,IPROC)=IBFIRST KGPTRSEND(2,IBLOCK,IPROC)=IBLAST IF(IBLOCK < NGPBLKS) IBLOCK=IBLOCK+1 IROF=0 IBFIRST=1 ENDIF IROF=IROF+1 ENDDO ENDDO IF(IROF /= 1.AND.IROF /= IBFIRST) THEN ! non-empty residual block after last latitude line IBLAST=IROF-1 KGPTRSEND(1,IBLOCK,IPROC)=IBFIRST KGPTRSEND(2,IBLOCK,IPROC)=IBLAST ENDIF ! sum up over blocks KGPTRRECV(:)=0 DO JPRTRNS=1,NPRTRNS DO JBLKS=1,NGPBLKS IF(KGPTRSEND(1,JBLKS,JPRTRNS) > 0) THEN KGPTRRECV(JPRTRNS)=KGPTRRECV(JPRTRNS)+& &KGPTRSEND(2,JBLKS,JPRTRNS)-KGPTRSEND(1,JBLKS,JPRTRNS)+1 ENDIF ENDDO ENDDO END SUBROUTINE INIGPTR END MODULE INIGPTR_MOD ectrans-1.8.0/src/trans/cpu/internal/suleg_mod.F900000664000175000017500000011560315174631767022151 0ustar alastairalastair! (C) Copyright 1987- ECMWF. ! (C) Copyright 1987- 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. ! MODULE SULEG_MOD CONTAINS SUBROUTINE SULEG !DEC$ OPTIMIZE:1 USE PARKIND1, ONLY: JPRD, JPIM, JPRB USE PARKIND2, ONLY: JPRH USE MPL_MODULE, ONLY: MPL_BYTES, MPL_BARRIER, JP_NON_BLOCKING_STANDARD, MPL_RECV, & & MPL_SEND, MPL_WAIT USE TPM_GEN, ONLY: NOUT, LMPOFF, NPRINTLEV USE TPM_DIM, ONLY: R USE TPM_CONSTANTS, ONLY: RA USE TPM_DISTR, ONLY: NPRTRV, NPRTRW, NPROC, D, MTAGLETR, MYPROC, MYSETV, MYSETW, NPRCIDS USE TPM_FIELDS, ONLY: F USE TPM_FLT, ONLY: S USE TPM_GEOMETRY, ONLY: G USE TPM_CTL, ONLY: C USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE PRE_SULEG_MOD, ONLY: PRE_SULEG USE SUGAW_MOD, ONLY: SUGAW USE SUPOL_MOD, ONLY: SUPOL USE SUPOLF_MOD, ONLY: SUPOLF USE TPM_POL, ONLY: INI_POL, END_POL USE SUTRLE_MOD, ONLY: SUTRLE USE SETUP_GEOM_MOD, ONLY: SETUP_GEOM USE BUTTERFLY_ALG_MOD, ONLY: CLONE, CONSTRUCT_BUTTERFLY, PACK_BUTTERFLY_STRUCT, & & UNPACK_BUTTERFLY_STRUCT USE SEEFMM_MIX, ONLY: SETUP_SEEFMM USE SET2PE_MOD, ONLY: SET2PE USE PREPSNM_MOD, ONLY: PREPSNM USE WRITE_LEGPOL_MOD, ONLY: WRITE_LEGPOL USE READ_LEGPOL_MOD, ONLY: READ_LEGPOL !**** *SULEG * - initialize the Legendre polynomials ! Purpose. ! -------- ! Initialize COMMON YOMLEG !** Interface. ! ---------- ! *CALL* *SULEG* ! Explicit arguments : ! -------------------- ! Implicit arguments : ! -------------------- ! COMMON YOMLEG ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! SUGAW (Gaussian latitudes) ! SUPOLM (polynomials) ! LFI routines for external IO's ! Called by SUGEM. ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! ! S.L. Belousov, Tables of normalized associated Legendre Polynomials, Pergamon Press (1962) ! P.N. Swarztrauber, On computing the points and weights for Gauss-Legendre quadrature, ! SIAM J. Sci. Comput. Vol. 24 (3) pp. 945-954 (2002) ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 87-10-15 ! MODIFICATION : 91-04 J.M. Piriou: ! - Read gaussian latitudes and PNM on LFI ! - If file missing, computes ! 91-04 M.Hamrud: ! - IO Scheme introduced ! MODIFICATION : 91-07-03 P.Courtier suppress derivatives ! MODIFICATION : 91-07-03 P.Courtier computes RATATH and RACTHE ! MODIFICATION : 91-07-03 P.Courtier change upper limit (NSMAX+1) ! MODIFICATION : 91-07-03 P.Courtier change ordering ! Order of the PNM in the file, as in the model : ! - increasing wave numbers m ! - for a given m, from n=NSMAX+1 to m ! MODIFICATION : 92-07-02 R. Bubnova: shift RATATH calculation ! to SUGEM1 ! MODIFICATION : 92-12-17 P.Courtier multitask computations ! Modified by R. EL Khatib : 93-04-02 Set-up defaults controled by LECMWF ! MODIFICATION : 93-03-19 D.Giard : n <= NTMAX ! K. YESSAD : 93-05-11 : DLMU --> global array DRMU(NDGSA:NDGEN). ! (not stored currently on LFI files). ! MODIFICATION : 94-02-03 R. El Khatib : subroutine SULEG2 to write out ! the Leg. polynomials on workfile or LFI file ! Modification : 94-08-31 M. Tolstykh: Setup for CUD interpolation ! Modified by K. YESSAD (MARCH 1995): Extra-latitudes computations ! according to value of NDGSUR and LRPOLE only. ! + change fancy loop numbering. ! Modified 98-08-10 by K. YESSAD: removal of LRPOLE option. ! - removal of LRPOLE in YOMCT0. ! - removal of code under LRPOLE. ! R. El Khatib 11-Apr-2007 Emulation of vectorized quadruple precision ! on NEC ! Nils Wedi + Mats Hamrud, 2009-02-05 revised following Swarztrauber, 2002 ! G.Mozdzynski: March 2011 Support 2D (RW,RV) initialisation of legendre coeffs ! G.Mozdzynski: July 2012 distribute FLT initialisation over NPRTRV ! R. El Khatib 14-Jun-2013 optional computation on the stretched latitudes ! F. Vana 05-Mar-2015 Support for single precision ! Nils Wedi, 20-Apr-2015 Support dual latitude/longitude set ! T. Wilhelmsson, 22-Sep-2016 Support single precision for dual too ! ------------------------------------------------------------------ IMPLICIT NONE ! LOCAL ! ------------------------------------------------------------------ REAL(KIND=JPRD),ALLOCATABLE :: ZPNMG(:) REAL(KIND=JPRD),ALLOCATABLE :: ZFN(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZLRMUZ2(:) REAL(KIND=JPRB) :: ZEPSNM(0:R%NTMAX+2) REAL(KIND=JPRD) :: ZLRMUZ(R%NDGL) REAL(KIND=JPRD) :: ZW(R%NDGL) REAL(KIND=JPRD) :: ZANM REAL(KIND=JPRD) :: ZFNN REAL(KIND=JPRD) :: ZPI, ZINC, ZOFF, ZTEMP, ZORIG, ZTHETA, ZCOS REAL(KIND=JPRD), ALLOCATABLE :: ZSNDBUFV(:),ZRCVBUFV(:,:) REAL(KIND=JPRD), ALLOCATABLE :: ZPNMCDO(:,:),ZPNMCDD(:,:) REAL(KIND=JPRB), ALLOCATABLE :: ZRCVBUTFV(:,:) REAL(KIND=JPRB) :: ZDUM(2) REAL(KIND=KIND(ZRCVBUTFV)) :: ZBYTES INTEGER(KIND=JPIM) :: IBYTES INTEGER(KIND=JPIM) :: ISENDREQ(NPRTRV) INTEGER(KIND=JPIM) :: IRECVREQ(NPRTRV) INTEGER(KIND=JPIM) :: IKOUNT(NPRTRV) INTEGER(KIND=JPIM) :: IRECVLENMAXV(NPRTRV) INTEGER(KIND=JPIM) :: INM, IM, IRECV, ISEND, ISREQ, IRREQ, & &JGL, JM, JMLOC, IMLOC, JN, JNM, IODD, INN, INMAX, JI, IMAXN, ITAG, ITAG1, & &INX, ISL, ISTART, ITHRESHOLD, INSMAX, IMAXCOLS,ILATSMAX,JW,JV,J, & &IDGLU, ILA, ILS, IA, IS, ILATS, ILOOP, IPRTRV, JSETV, JH, & &IMAXRECVA, IMAXRECVS, IRECVLENMAX, ICLONELEN, IHEMIS, INNH, IGL, IGL1, IGL2, & &IDGLU2, ISYM, INZ REAL(KIND=JPRD) :: ZEPS_INT_DEC REAL(KIND=JPRD) :: ZEPS REAL(KIND=JPRD),ALLOCATABLE :: ZLFPOL(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZLPOL(:) TYPE(CLONE),ALLOCATABLE :: ZCLONEA(:),ZCLONES(:) LOGICAL :: LLP1,LLP2 ! For latitudes on the stretched geometry REAL(KIND=JPRH) :: ZTAN REAL(KIND=JPRH) :: ZSTRETMU(R%NDGL) ! ------------------------------------------------------------------ !* 0. Some initializations. ! --------------------- IBYTES = MPL_BYTES(ZBYTES) ZEPS = 1000._JPRD*EPSILON(ZEPS) !ZEPS_INT_DEC = EPSILON(ZEPS) ZEPS_INT_DEC = 1.0E-7_JPRD !ZEPS_INT_DEC = 1.0E-5_JPRD IHEMIS=1 IF (S%LSOUTHPNM) IHEMIS=2 LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SULEG ===' IF( NPROC > 1 )THEN CALL GSTATS(798,0) CALL MPL_BARRIER(CDSTRING='SULEG:') CALL GSTATS(798,1) ENDIF CALL GSTATS(140,0) CALL GSTATS(1801,0) IF(.NOT.D%LGRIDONLY) THEN CALL PRE_SULEG ENDIF ALLOCATE(F%RMU(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%RMU ',SIZE(F%RMU ),SHAPE(F%RMU ) ALLOCATE(F%RW(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%RW ',SIZE(F%RW ),SHAPE(F%RW ) !* 1.0 Initialize Fourier coefficients for ordinary Legendre polynomials ! ------------------------------------------------------------------------ ALLOCATE(ZFN(0:R%NDGL,0:R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'ZFN ',SIZE(ZFN ),SHAPE(ZFN ) ! determines the number of stripes in butterfly NSMAX/IMAXCOLS ! IMAXCOLS = (R%NSMAX - 1)/4 + 1 ! IMAXCOLS=64 (min flops) IMAXCOLS=64 ! the threshold of efficiency IF(NPROC == 1 .OR. R%NDGNH <= 2560) THEN ITHRESHOLD = R%NDGNH/4 DO IF(ITHRESHOLD >= IMAXCOLS*4) EXIT IMAXCOLS = IMAXCOLS/2 ENDDO ELSE ITHRESHOLD = 900 ENDIF ITHRESHOLD = MAX(ITHRESHOLD,IMAXCOLS+1) S%ITHRESHOLD = ITHRESHOLD !* 3.1 Gaussian latitudes and weights ! --------------------------------------- CALL INI_POL(R%NTMAX+3) IF(.NOT.D%LGRIDONLY) THEN ISTART=1 ELSE ISTART=R%NDGL ENDIF INMAX=R%NDGL ! Belousov, Swarztrauber use ZFN(0,0)=SQRT(2._JPRD) ! IFS normalisation chosen to be 0.5*Integral(Pnm**2) = 1 ZFN(0,0)=2._JPRD DO JN=ISTART,R%NDGL ZFNN=ZFN(0,0) DO JGL=1,JN ZFNN=ZFNN*SQRT(1._JPRD-0.25_JPRD/REAL(JGL**2,JPRD)) ENDDO IODD=MOD(JN,2) ZFN(JN,JN)=ZFNN DO JGL=2,JN-IODD,2 ZFN(JN,JN-JGL)=ZFN(JN,JN-JGL+2)*REAL((JGL-1)*(2*JN-JGL+2),JPRD)/REAL(JGL*(2*JN-JGL+1),JPRD) ENDDO ENDDO ! compute latitudes and weights for original Gaussian latitudes ZANM=SQRT(REAL(2*INMAX+1,JPRD)*REAL(INMAX**2,JPRD)/REAL(2*INMAX-1,JPRD)) INN=R%NDGL CALL GSTATS(1801,2) CALL SUGAW(INN,0,INMAX,ZLRMUZ(1:INN),ZW(1:INN),ZANM,ZFN) CALL GSTATS(1801,3) IF (ABS(G%RSTRET-1.0_JPRD)>100._JPRD*EPSILON(1._JPRD)) THEN WRITE(NOUT,*) '=== SULEG: Change Gaussian latitudes to the transformed sphere ===' INNH=(INN+1)/2 ZTAN=(1.0_JPRD-G%RSTRET**2)/(1.0_JPRD+G%RSTRET**2) ! North hemisphere DO JGL=1,INNH ZSTRETMU(JGL)=(ZTAN+REAL(ZLRMUZ(JGL),JPRH))/(1.0_JPRD+ZTAN*REAL(ZLRMUZ(JGL),JPRH)) ENDDO ! South hemisphere DO JGL=1,INNH IGL=2*INNH-JGL+1 ZSTRETMU(IGL)=(ZTAN-REAL(ZLRMUZ(JGL),JPRH))/(1.0_JPRD-ZTAN*REAL(ZLRMUZ(JGL),JPRH)) ENDDO DO JGL=1,INN ZLRMUZ(JGL)=REAL(ZSTRETMU(JGL),JPRD) ENDDO ENDIF DO JGL=1,R%NDGL F%RW(JGL) = ZW(JGL) F%RMU(JGL) = ZLRMUZ(JGL) ENDDO IF (LLP1) WRITE(NOUT,*) '=== SULEG: Finished Gaussian latitudes ===' !* 3.1.1 specify a dual set of output (inv_trans) or input (dir_trans) latitudes / longitudes IF( S%LDLL ) THEN INMAX = S%NDGL INN= S%NDGL S%NDGNHD = (INMAX+1)/2 ALLOCATE(ZLRMUZ2(INN)) ! here we want to use the positions of the specified dual grid ! accuracy requirement is ZLRMUZ2(JGL) < F%RMU(1) ! so we use approximations for the remaining latitudes outside this range ! we approximate the vicinity to the pole/equator ZPI = 2.0_JPRD*ASIN(1.0_JPRD) ZORIG = ASIN(F%RMU(1)) IF( S%LSHIFTLL ) THEN ZINC = ZPI/REAL(INN,JPRD) ZOFF = 0.5_JPRD*ZINC ZTEMP = ZOFF + ZINC*REAL(S%NDGNHD-1,JPRD) ZLRMUZ2(1) = SIN(MIN(ZTEMP,ZORIG) - 0.5_JPRD*MAX(0._JPRD,ZTEMP - ZORIG)) ZLRMUZ2(S%NDGNHD) = SIN(ZOFF) ELSE ZINC = ZPI/REAL(INN-2,JPRD) ZOFF=-0.5_JPRD*ZINC ZTEMP = ZOFF + ZINC*REAL(S%NDGNHD-1,JPRD) ZLRMUZ2(1) = SIN(MIN(ZTEMP,ZORIG) - 0.5_JPRD*MAX(0._JPRD,ZTEMP - ZORIG)) ZOFF=0.01_JPRD*ZINC ZLRMUZ2(S%NDGNHD) = SIN(ZOFF) ZOFF=0._JPRD ENDIF DO JGL=2, S%NDGNHD-1 ZLRMUZ2(JGL) = SIN(ZOFF + ZINC*REAL(S%NDGNHD-JGL,JPRD)) ENDDO DO JGL=1, S%NDGNHD ISYM = INN-JGL+1 ZLRMUZ2(ISYM) = -ZLRMUZ2(JGL) ENDDO IF( LLP2 ) THEN WRITE(NOUT,*) 'dual latitudes' DO JGL= 1, INN WRITE(NOUT,*) 'dual JGL=',JGL,(180._JPRD/ZPI)*ZINC,(180._JPRD/ZPI)*ASIN(ZLRMUZ2(JGL)),& & (180._JPRD/ZPI)*ASIN(F%RMU(JGL)) ENDDO ENDIF ALLOCATE(F%RMU2(INMAX)) IF (LLP2) WRITE(NOUT,9) 'F%RMU2 ',SIZE(F%RMU2 ),SHAPE(F%RMU2 ) ALLOCATE(F%RACTHE2(INMAX)) IF (LLP2) WRITE(NOUT,9) 'F%RACTHE2 ',SIZE(F%RACTHE2),SHAPE(F%RACTHE2 ) DO JGL=1,INN F%RMU2(JGL) = ZLRMUZ2(JGL) F%RACTHE2(JGL) = 1.0_JPRD/(SQRT(1.0_JPRD-ZLRMUZ2(JGL)*ZLRMUZ2(JGL))+ZEPS)/REAL(RA,JPRD) ENDDO IF (LLP1) WRITE(NOUT,*) '=== SULEG: Finished dual Gaussian latitudes ===' ! inverse + direct map for FMM INX=2*R%NDGNH INZ=2*S%NDGNHD ALLOCATE(S%FMM_INTI) CALL SETUP_SEEFMM(INX,F%RMU,INZ,F%RMU2,S%FMM_INTI) ENDIF !* 3.2 Computes related arrays IF(.NOT.D%LGRIDONLY) THEN ALLOCATE(S%FA(D%NUMP)) ALLOCATE(F%R1MU2(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%R1MU2 ',SIZE(F%R1MU2),SHAPE(F%R1MU2 ) ALLOCATE(F%RACTHE(R%NDGL)) IF (LLP2) WRITE(NOUT,9) 'F%RACTHE ',SIZE(F%RACTHE),SHAPE(F%RACTHE ) IF( S%LUSE_BELUSOV) THEN ALLOCATE(F%RPNM(R%NLEI3,D%NSPOLEGL)) IF (LLP2) WRITE(NOUT,9) 'F%RPNM ',SIZE(F%RPNM),SHAPE(F%RPNM) DO JNM=1,D%NSPOLEGL F%RPNM(R%NLEI3,JNM) = 0.0_JPRD ENDDO ENDIF !* 3.2 Computes related arrays DO JGL=1,R%NDGL ! test cosine differently ZTHETA = ASIN(ZLRMUZ(JGL)) ZCOS = COS(ZTHETA) F%R1MU2(JGL) = ZCOS**2 F%RACTHE(JGL) = 1.0_JPRD/ZCOS/REAL(RA,JPRD) ENDDO !* 3.3 Working arrays ! compute the Legendre polynomials as a function of the z_k (Gaussian Latitudes) ! this may be faster than calling supolf for each m but uses extra communication ! and the parallelism is more limited ? Nils IF( S%LUSE_BELUSOV .AND. .NOT. C%LREAD_LEGPOL ) THEN INSMAX = R%NTMAX+1 IF( INSMAX /= R%NDGL) THEN DEALLOCATE(ZFN) ALLOCATE(ZFN(0:INSMAX,0:INSMAX)) ! Belousov, Swarztrauber use ZFN(0,0)=SQRT(2._JPRD) ! IFS normalisation chosen to be 0.5*Integral(Pnm**2) = 1 ZFN(0,0)=2._JPRD DO JN=1,INSMAX ZFNN=ZFN(0,0) DO JGL=1,JN ZFNN=ZFNN*SQRT(1._JPRD-0.25_JPRD/REAL(JGL**2,JPRD)) ENDDO IODD=MOD(JN,2) ZFN(JN,JN)=ZFNN DO JGL=2,JN-IODD,2 ZFN(JN,JN-JGL)=ZFN(JN,JN-JGL+2)*REAL((JGL-1)*(2*JN-JGL+2),JPRD)/REAL(JGL*(2*JN-JGL+1),JPRD) ENDDO ENDDO ENDIF ALLOCATE(ZLFPOL(0:INSMAX,0:INSMAX)) ALLOCATE(ZPNMG(R%NSPOLEG)) DO JH=1,IHEMIS IF (JH==1) THEN IGL1=D%NLATLS(MYSETW,MYSETV) IGL2=D%NLATLE(MYSETW,MYSETV) ELSE IGL1=R%NDGL-D%NLATLE(MYSETW,MYSETV)+1 IGL2=R%NDGL-D%NLATLS(MYSETW,MYSETV)+1 ENDIF ILOOP=0 DO JGL=IGL1,IGL2 INM = 0 CALL SUPOL(INSMAX,ZLRMUZ(JGL),ZFN,ZLFPOL) DO JM=0,R%NSMAX DO JN=INSMAX,JM,-1 INM = INM+1 ZPNMG(INM) = ZLFPOL(JM,JN) ENDDO ENDDO CALL GSTATS(1801,2) ILOOP = JGL-IGL1+1 CALL SUTRLE(ZPNMG,JGL,ILOOP) CALL GSTATS(1801,3) ENDDO ILATSMAX=0 DO JW=1,NPRTRW DO JV=1,NPRTRV ILATSMAX=MAX(ILATSMAX,D%NLATLE(JW,JV)-D%NLATLS(JW,JV)+1) ENDDO ENDDO ILATS=IGL2-IGL1+1 IF (S%LSOUTHPNM .AND. IHEMIS==1 .AND. ILATSMAX-1 >= ILATS) THEN ! I don't know what to do for south pole. But isn't this piece of code ! a dead stuff for poles rows ? CALL ABORT_TRANS('SULEG: WILL BE BROKEN FOR SOUTH HEMISPHERE') ENDIF DO J=ILATS,ILATSMAX-1 ILOOP=ILOOP+1 CALL GSTATS(1801,2) CALL SUTRLE(ZPNMG,-1,ILOOP) CALL GSTATS(1801,3) ENDDO ENDDO DEALLOCATE(ZLFPOL) IF( ALLOCATED(ZFN) ) DEALLOCATE(ZFN) DEALLOCATE(ZPNMG) IF(LLP1) WRITE(NOUT,*) '=== SULEG: Finished RPNM ===' ENDIF CALL SETUP_GEOM IMAXN=R%NTMAX+1 ITAG=MTAGLETR ITAG1=MTAGLETR+1 IMAXRECVA=0 IMAXRECVS=0 DO JMLOC=1,D%NUMP IM = D%MYMS(JMLOC) ILA = (R%NSMAX-IM+2)/2 ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IMAXRECVA = MAX(IDGLU*ILA,IMAXRECVA) IMAXRECVS = MAX(IDGLU*ILS,IMAXRECVS) !find nearest starting latitude of the dual set IF( S%LDLL ) THEN INMAX=MIN(R%NTMAX+1,S%NDGL) IDGLU2=S%NDGNHD S%FA(JMLOC)%ISLD = 1 LLA:DO JGL=1,S%NDGNHD-1 IF( (ZLRMUZ2(JGL) < ZLRMUZ(ISL)) ) THEN S%FA(JMLOC)%ISLD = JGL IDGLU2 = S%NDGNHD-S%FA(JMLOC)%ISLD+1 EXIT LLA ENDIF ENDDO LLA IF( .NOT. C%LREAD_LEGPOL ) THEN ! compute auxiliary quantities for the dual mapping ! output data latitudes ALLOCATE(ZPNMCDO(2*IDGLU2,2)) !$OMP PARALLEL PRIVATE(JGL,ZLPOL) IF (.NOT.ALLOCATED(ZLPOL)) ALLOCATE(ZLPOL(0:INMAX)) !$OMP DO SCHEDULE(DYNAMIC,1) DO JGL=1,2*IDGLU2 CALL SUPOLF(IM,INMAX,ZLRMUZ2(S%FA(JMLOC)%ISLD+JGL-1),ZLPOL(0:INMAX)) ZPNMCDO(JGL,1)=ZLPOL(INMAX-1) ZPNMCDO(JGL,2)=ZLPOL(INMAX) ENDDO !$OMP END DO IF (ALLOCATED(ZLPOL)) DEALLOCATE(ZLPOL) !$OMP END PARALLEL ! internal (gg-roots) latitudes ALLOCATE(ZPNMCDD(2*IDGLU,2)) !$OMP PARALLEL PRIVATE(JGL,ZLPOL,JI,JN) IF (.NOT.ALLOCATED(ZLPOL)) ALLOCATE(ZLPOL(0:INMAX)) !$OMP DO SCHEDULE(DYNAMIC,1) DO JGL=1,2*IDGLU CALL SUPOLF(IM,INMAX,ZLRMUZ(ISL+JGL-1),ZLPOL(0:INMAX)) ZPNMCDD(JGL,1)=ZLPOL(INMAX-1) ZPNMCDD(JGL,2)=ZLPOL(INMAX) ENDDO !$OMP END DO IF (ALLOCATED(ZLPOL)) DEALLOCATE(ZLPOL) !$OMP END PARALLEL CALL PREPSNM(IM,JMLOC,ZEPSNM) ALLOCATE(S%FA(JMLOC)%RPNMWI(2*IDGLU,1:2)) DO JGL=1,2*IDGLU ! inverse trafo S%FA(JMLOC)%RPNMWI(JGL,1) = F%RW(ISL+JGL-1)*ZPNMCDD(JGL,1) S%FA(JMLOC)%RPNMWI(JGL,2) = F%RW(ISL+JGL-1)*ZPNMCDD(JGL,2) ! direct trafo needed if mapping to another set of gg roots !S%FA(JMLOC)%RPNMWI(JGL,3) = -ZEPSNM(IMAXN)*ZPNMCDD(JGL,2) !S%FA(JMLOC)%RPNMWI(JGL,4) = -ZEPSNM(IMAXN)*ZPNMCDD(JGL,1) ENDDO DEALLOCATE(ZPNMCDD) ALLOCATE(S%FA(JMLOC)%RPNMWO(2*IDGLU2,1:2)) DO JGL=1,2*IDGLU2 ! inverse trafo S%FA(JMLOC)%RPNMWO(JGL,1) = -ZEPSNM(IMAXN)*ZPNMCDO(JGL,2) S%FA(JMLOC)%RPNMWO(JGL,2) = -ZEPSNM(IMAXN)*ZPNMCDO(JGL,1) ! only needed in direct trafo, need if mapping to another set of roots !S%FA(JMLOC)%RPNMWO(JGL,3) = F%RW2(S%FA(JMLOC)%ISLD+JGL-1)*ZPNMCDO(JGL,1) !S%FA(JMLOC)%RPNMWO(JGL,4) = F%RW2(S%FA(JMLOC)%ISLD+JGL-1)*ZPNMCDO(JGL,2) ENDDO DEALLOCATE(ZPNMCDO) ENDIF ! LREAD_LEGPOL ENDIF ! LDLL ENDDO IF( S%LDLL ) THEN DEALLOCATE(ZLRMUZ2) ENDIF CALL GSTATS(1801,2) IF(.NOT.C%LREAD_LEGPOL) THEN IF( S%LUSEFLT )THEN ALLOCATE(ZCLONEA(D%NUMP)) ALLOCATE(ZCLONES(D%NUMP)) ENDIF ! Loop over all zonal wavenumbers I'm responsible for, in strides of NPRTRV ! Every member of the same W set needs exactly the same polynomials ! Rather than have one member from each W set compute all the polynomials and then communicate ! them to the others, each member in the W set is recruited to calculate exactly one polynomial ! E.g. MYSETV=1 computes the first, MYSETV=2 the second, and so on ! This way the cost of precomputing the polynomials is shared among all members of the W set ! Each member then communicates its polynomial to the other members, so they all have a ! complete set DO JMLOC = 1, D%NUMP, NPRTRV IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) ! --------------------anti-symmetric----------------------- ! Allocate antisymmetric polynomials for this batch of NPRTRV zonal wavenumbers DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(S%FA(IMLOC)%RPNMA(IDGLU,ILA)) ENDDO IF( .NOT. S%LUSE_BELUSOV ) THEN ISREQ = 0 IRREQ = 0 ! Post receives for all polynomials in this NPRTRV batch ALLOCATE (ZRCVBUFV(IMAXRECVA,IPRTRV)) CALL GSTATS(851,0) DO JSETV=1,IPRTRV CALL SET2PE(IRECV,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN IRREQ = IRREQ+1 CALL MPL_RECV(ZRCVBUFV(:,JSETV),KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) IF( JMLOC+MYSETV-1 <= D%NUMP )THEN ! Determine properties of the polynomial I'm responsible for IMLOC=JMLOC+MYSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(ZSNDBUFV(IDGLU*ILA)) IF(MOD(IMAXN-IM,2) == 0) THEN INMAX=IMAXN+1 ELSE INMAX=IMAXN ENDIF ! Calculate my polynomial with SUPOLF CALL GSTATS(1251,0) IF (.NOT.ALLOCATED(ZLPOL)) ALLOCATE(ZLPOL(0:INMAX)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,ZLPOL,JI,JN) DO JGL=1,IDGLU CALL SUPOLF(IM,INMAX,ZLRMUZ(ISL+JGL-1),ZLPOL(0:INMAX),KCHEAP=3) DO JI=1,ILA JN=IM+2*(JI-1)+1 ZSNDBUFV((JGL-1)*ILA+JI)=ZLPOL(JN) ENDDO ENDDO !$OMP END PARALLEL DO IF (ALLOCATED(ZLPOL)) DEALLOCATE(ZLPOL) CALL GSTATS(1251,1) ! Post sends to the other members of my W set CALL GSTATS(851,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZSNDBUFV(:),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) ENDIF CALL GSTATS(851,0) IF(IRREQ > 0) THEN CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF(ISREQ > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF( NPROC==1.AND.LMPOFF )THEN ZRCVBUFV(1:SIZE(ZSNDBUFV(:)),1)=ZSNDBUFV(:) ENDIF CALL GSTATS(851,1) ! Now unpack the polynomials I've received into their respective storage work arrays CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IA,ILA,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IF( S%LUSEFLT .AND. ILA > ITHRESHOLD ) THEN IF( .NOT. S%LKEEPRPNM ) DEALLOCATE(S%FA(IMLOC)%RPNMA) ALLOCATE(S%FA(IMLOC)%RPNMDA(IDGLU,ILA)) DO JGL=1,IDGLU DO JI=1,ILA S%FA(IMLOC)%RPNMDA(JGL,ILA-JI+1)=ZRCVBUFV((JGL-1)*ILA+JI,JSETV) ENDDO ENDDO IF( S%LKEEPRPNM ) THEN DO JGL=1,IDGLU DO JI=1,ILA S%FA(IMLOC)%RPNMA(JGL,ILA-JI+1)=ZRCVBUFV((JGL-1)*ILA+JI,JSETV) ENDDO ENDDO ENDIF ELSE DO JGL=1,IDGLU DO JI=1,ILA S%FA(IMLOC)%RPNMA(JGL,ILA-JI+1)=ZRCVBUFV((JGL-1)*ILA+JI,JSETV) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1251,1) IF( ALLOCATED(ZSNDBUFV) ) DEALLOCATE(ZSNDBUFV) IF( ALLOCATED(ZRCVBUFV) ) DEALLOCATE(ZRCVBUFV) ELSE ! Take the values from the arrays computed earlier with the Belusov algorithm CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IA,ILA,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IF( S%LUSEFLT .AND. ILA > ITHRESHOLD ) THEN IF( .NOT. S%LKEEPRPNM ) DEALLOCATE(S%FA(IMLOC)%RPNMA) ALLOCATE(S%FA(IMLOC)%RPNMDA(IDGLU,ILA)) DO JI=1,ILA DO JGL=1,IDGLU S%FA(IMLOC)%RPNMDA(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IA+(JI-1)*2) ENDDO ENDDO IF( S%LKEEPRPNM ) THEN DO JI=1,ILA DO JGL=1,IDGLU S%FA(IMLOC)%RPNMA(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IA+(JI-1)*2) ENDDO ENDDO ENDIF ELSE DO JI=1,ILA DO JGL=1,IDGLU S%FA(IMLOC)%RPNMA(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IA+(JI-1)*2) ENDDO ENDDO END IF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1251,1) ENDIF ! -------------------- anti-symmetric FLT iniitialisation ----------------------- IF( S%LUSEFLT) THEN IRECVLENMAX=0 ISREQ = 0 IRREQ = 0 IF( JMLOC+MYSETV-1 <= D%NUMP )THEN IMLOC=JMLOC+MYSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IF( ILA > ITHRESHOLD ) THEN INX = IDGLU CALL CONSTRUCT_BUTTERFLY(ZEPS_INT_DEC,IMAXCOLS,INX,ILA,S%FA(IMLOC)%RPNMDA,& & S%FA(IMLOC)%YBUT_STRUCT_A) CALL PACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,ZCLONEA(IMLOC)) IRECVLENMAX=SIZE(ZCLONEA(IMLOC)%COMMSBUF) CALL GSTATS(852,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF(.NOT.LMPOFF) THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZCLONEA(IMLOC)%COMMSBUF(:),KDEST=NPRCIDS(ISEND),& & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(852,1) ELSE IRECVLENMAX=2 ZDUM(:)=0.0_JPRB CALL GSTATS(852,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF(.NOT.LMPOFF) THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZDUM(:),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(852,1) ENDIF ENDIF IF(.NOT.LMPOFF) THEN CALL GSTATS(852,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) CALL MPL_SEND(IRECVLENMAX,KDEST=NPRCIDS(ISEND),KTAG=ITAG1,CDSTRING='SULEG:') ENDDO IRECVLENMAX=0 DO JSETV=1,NPRTRV ! ? should this be IPRTRV ? CALL SET2PE(IRECV,0,0,MYSETW,JSETV) CALL MPL_RECV(IRECVLENMAXV(JSETV),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG1,CDSTRING='SULEG:') IRECVLENMAX=MAX(IRECVLENMAX,IRECVLENMAXV(JSETV)) ENDDO IF( MYPROC == 1 .AND. LLP1 )THEN IF( IRECVLENMAX > 2 )THEN WRITE(NOUT,'("SULEG: ANTI-SYM MAX BUTTERFLY CLONE LEN=",I8)')IRECVLENMAX ENDIF ENDIF IF( IRECVLENMAX == 0 )THEN WRITE(NOUT,'("SULEG: ANTI-SYM WARNING CLONE LEN=",I8,I8)') MYPROC, IRECVLENMAX ENDIF IF( IRECVLENMAX > 0 )THEN ALLOCATE (ZRCVBUTFV(IRECVLENMAX,IPRTRV)) DO JSETV=1,IPRTRV IRREQ = IRREQ+1 CALL SET2PE(IRECV,0,0,MYSETW,JSETV) CALL MPL_RECV(ZRCVBUTFV(:,JSETV),KSOURCE=NPRCIDS(IRECV), & &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDDO END IF IF(ISREQ > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF(IRREQ > 0) THEN CALL MPL_WAIT(KBYTES=IBYTES,KOUNT=IKOUNT(1:IRREQ),KREQUEST=IRECVREQ(1:IRREQ), & & CDSTRING='SUTRLE: SULEG') ENDIF CALL GSTATS(852,1) IF( IRECVLENMAX > 0 )THEN CALL GSTATS(1252,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ILA,IDGLU,INX,ICLONELEN) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILA = (R%NSMAX-IM+2)/2 IF( ILA > ITHRESHOLD ) THEN IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) INX=IDGLU IF( .NOT.ALLOCATED(ZCLONEA(IMLOC)%COMMSBUF) )THEN ICLONELEN=IKOUNT(JSETV) ALLOCATE(ZCLONEA(IMLOC)%COMMSBUF(ICLONELEN)) ZCLONEA(IMLOC)%COMMSBUF(1:ICLONELEN) = ZRCVBUTFV(1:ICLONELEN,JSETV) CALL UNPACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_A,ZCLONEA(IMLOC)) ENDIF IF( STORAGE_SIZE(ZCLONEA(IMLOC)%COMMSBUF) > 0 ) DEALLOCATE(ZCLONEA(IMLOC)%COMMSBUF) IF( ASSOCIATED(S%FA(IMLOC)%RPNMA) .AND. .NOT. S%LKEEPRPNM ) DEALLOCATE(S%FA(IMLOC)%RPNMA) IF( ASSOCIATED(S%FA(IMLOC)%RPNMDA) ) DEALLOCATE(S%FA(IMLOC)%RPNMDA) ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1252,1) DEALLOCATE(ZRCVBUTFV) ENDIF ENDIF ENDIF ! --------------------symmetric----------------------- ! Allocate symmetric polynomials for this batch of NPRTRV zonal wavenumbers DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(S%FA(IMLOC)%RPNMS(IDGLU,ILS)) ENDDO IF( .NOT. S%LUSE_BELUSOV ) THEN ISREQ = 0 IRREQ = 0 ! Post receives for all polynomials in this NPRTRV batch ALLOCATE (ZRCVBUFV(IMAXRECVS,IPRTRV)) CALL GSTATS(851,0) DO JSETV=1,IPRTRV CALL SET2PE(IRECV,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN IRREQ = IRREQ+1 CALL MPL_RECV(ZRCVBUFV(:,JSETV),KSOURCE=NPRCIDS(IRECV), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) IF( JMLOC+MYSETV-1 <= D%NUMP )THEN ! Determine properties of the polynomial I'm responsible for IMLOC=JMLOC+MYSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) ALLOCATE(ZSNDBUFV(IDGLU*ILS)) IF(MOD(IMAXN-IM,2) == 0) THEN INMAX=IMAXN ELSE INMAX=IMAXN+1 ENDIF ! Calculate my polynomial with SUPOLF CALL GSTATS(1251,0) IF (.NOT.ALLOCATED(ZLPOL)) ALLOCATE(ZLPOL(0:INMAX)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,ZLPOL,JI,JN) DO JGL=1,IDGLU CALL SUPOLF(IM,INMAX,ZLRMUZ(ISL+JGL-1),ZLPOL(0:INMAX),KCHEAP=2) DO JI=1,ILS JN=IM+2*(JI-1) ZSNDBUFV((JGL-1)*ILS+JI)=ZLPOL(JN) ENDDO ENDDO !$OMP END PARALLEL DO IF (ALLOCATED(ZLPOL)) DEALLOCATE(ZLPOL) CALL GSTATS(1251,1) ! Post sends to the other members of my W set CALL GSTATS(851,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF( .NOT.LMPOFF )THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZSNDBUFV(:),KDEST=NPRCIDS(ISEND), & & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(851,1) ENDIF CALL GSTATS(851,0) IF(IRREQ > 0) THEN CALL MPL_WAIT(KREQUEST=IRECVREQ(1:IRREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF(ISREQ > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF( NPROC==1.AND.LMPOFF )THEN ZRCVBUFV(1:SIZE(ZSNDBUFV(:)),1)=ZSNDBUFV(:) ENDIF CALL GSTATS(851,1) ! Now unpack the polynomials I've received into their respective storage work arrays CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IS,ILS,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IF( S%LUSEFLT .AND. ILS > ITHRESHOLD ) THEN IF( .NOT. S%LKEEPRPNM ) DEALLOCATE(S%FA(IMLOC)%RPNMS) ALLOCATE(S%FA(IMLOC)%RPNMDS(IDGLU,ILS)) DO JGL=1,IDGLU DO JI=1,ILS S%FA(IMLOC)%RPNMDS(JGL,ILS-JI+1)=ZRCVBUFV((JGL-1)*ILS+JI,JSETV) ENDDO ENDDO IF( S%LKEEPRPNM ) THEN DO JGL=1,IDGLU DO JI=1,ILS S%FA(IMLOC)%RPNMS(JGL,ILS-JI+1)=ZRCVBUFV((JGL-1)*ILS+JI,JSETV) ENDDO ENDDO ENDIF ELSE DO JGL=1,IDGLU DO JI=1,ILS S%FA(IMLOC)%RPNMS(JGL,ILS-JI+1)=ZRCVBUFV((JGL-1)*ILS+JI,JSETV) ENDDO ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1251,1) IF( ALLOCATED(ZSNDBUFV) ) DEALLOCATE(ZSNDBUFV) IF( ALLOCATED(ZRCVBUFV) ) DEALLOCATE(ZRCVBUFV) ELSE ! Take the values from the arrays computed earlier with the Belusov algorithm CALL GSTATS(1251,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ISL,IS,ILS,IDGLU,JGL,JI) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IF( S%LUSEFLT .AND. ILS > ITHRESHOLD ) THEN IF( .NOT. S%LKEEPRPNM ) DEALLOCATE(S%FA(IMLOC)%RPNMS) ALLOCATE(S%FA(IMLOC)%RPNMDS(IDGLU,ILS)) DO JI=1,ILS DO JGL=1,IDGLU S%FA(IMLOC)%RPNMDS(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IS+(JI-1)*2) ENDDO ENDDO IF( S%LKEEPRPNM ) THEN DO JI=1,ILS DO JGL=1,IDGLU S%FA(IMLOC)%RPNMS(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IS+(JI-1)*2) ENDDO ENDDO ENDIF ELSE DO JI=1,ILS DO JGL=1,IDGLU S%FA(IMLOC)%RPNMS(JGL,JI) = F%RPNM(ISL+JGL-1,D%NPMS(IM)+IS+(JI-1)*2) ENDDO ENDDO END IF END DO !$OMP END PARALLEL DO CALL GSTATS(1251,1) ENDIF ! -------------------- symmetric FLT iniitialisation ----------------------- IF( S%LUSEFLT) THEN IRECVLENMAX=0 ISREQ = 0 IRREQ = 0 IF( JMLOC+MYSETV-1 <= D%NUMP )THEN IMLOC=JMLOC+MYSETV-1 IM = D%MYMS(IMLOC) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) IF( ILS > ITHRESHOLD ) THEN INX = IDGLU CALL CONSTRUCT_BUTTERFLY(ZEPS_INT_DEC,IMAXCOLS,INX,ILS,S%FA(IMLOC)%RPNMDS,& & S%FA(IMLOC)%YBUT_STRUCT_S) CALL PACK_BUTTERFLY_STRUCT(S%FA(IMLOC)%YBUT_STRUCT_S,ZCLONES(IMLOC)) IRECVLENMAX=SIZE(ZCLONES(IMLOC)%COMMSBUF) CALL GSTATS(852,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF(.NOT.LMPOFF) THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZCLONES(IMLOC)%COMMSBUF(:),KDEST=NPRCIDS(ISEND),& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(852,1) ELSE IRECVLENMAX=2 ZDUM(:)=0.0_JPRB CALL GSTATS(852,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) IF(.NOT.LMPOFF) THEN ISREQ = ISREQ+1 CALL MPL_SEND(ZDUM(:),KDEST=NPRCIDS(ISEND), & &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(ISREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDIF ENDDO CALL GSTATS(852,1) ENDIF ENDIF IF(.NOT. LMPOFF) THEN CALL GSTATS(852,0) DO JSETV=1,NPRTRV CALL SET2PE(ISEND,0,0,MYSETW,JSETV) CALL MPL_SEND(IRECVLENMAX,KDEST=NPRCIDS(ISEND),KTAG=ITAG1,CDSTRING='SULEG:') ENDDO IRECVLENMAX=0 DO JSETV=1,NPRTRV ! ? should this be IPRTRV ? CALL SET2PE(IRECV,0,0,MYSETW,JSETV) CALL MPL_RECV(IRECVLENMAXV(JSETV),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG1,CDSTRING='SULEG:') IRECVLENMAX=MAX(IRECVLENMAX,IRECVLENMAXV(JSETV)) ENDDO IF( MYPROC == 1 .AND. LLP1 )THEN IF( IRECVLENMAX > 2 )THEN WRITE(NOUT,'("SULEG: SYM MAX BUTTERFLY CLONE LEN=",I8)')IRECVLENMAX ENDIF ENDIF IF( IRECVLENMAX == 0 )THEN WRITE(NOUT,'("SULEG: SYM WARNING CLONE LEN=",I8,I8)')MYPROC, IRECVLENMAX ENDIF IF( IRECVLENMAX > 0 )THEN ALLOCATE (ZRCVBUTFV(IRECVLENMAX,IPRTRV)) DO JSETV=1,IPRTRV IRREQ = IRREQ+1 CALL SET2PE(IRECV,0,0,MYSETW,JSETV) CALL MPL_RECV(ZRCVBUTFV(:,JSETV),KSOURCE=NPRCIDS(IRECV), & &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(IRREQ),& & KTAG=ITAG,CDSTRING='SULEG:') ENDDO ENDIF IF(ISREQ > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(1:ISREQ), CDSTRING='SUTRLE: SULEG') ENDIF IF(IRREQ > 0) THEN CALL MPL_WAIT(KBYTES=IBYTES,KOUNT=IKOUNT(1:IRREQ),KREQUEST=IRECVREQ(1:IRREQ), & & CDSTRING='SUTRLE: SULEG') ENDIF CALL GSTATS(852,1) IF( IRECVLENMAX > 0 )THEN CALL GSTATS(1252,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JSETV,IMLOC,IM,ILS,IDGLU,INX,ICLONELEN) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ILS = (R%NSMAX-IM+3)/2 IF( ILS > ITHRESHOLD ) THEN IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) INX=IDGLU IF( .NOT.ALLOCATED(ZCLONES(IMLOC)%COMMSBUF) )THEN ICLONELEN=IKOUNT(JSETV) ALLOCATE(ZCLONES(IMLOC)%COMMSBUF(ICLONELEN)) ZCLONES(IMLOC)%COMMSBUF(1:ICLONELEN) = ZRCVBUTFV(1:ICLONELEN,JSETV) CALL UNPACK_BUTTERFLY_STRUCT( S%FA(IMLOC)%YBUT_STRUCT_S,ZCLONES(IMLOC)) ENDIF IF( STORAGE_SIZE(ZCLONES(IMLOC)%COMMSBUF) > 0 ) DEALLOCATE(ZCLONES(IMLOC)%COMMSBUF) IF( ASSOCIATED(S%FA(IMLOC)%RPNMS) .AND. .NOT. S%LKEEPRPNM ) DEALLOCATE(S%FA(IMLOC)%RPNMS) IF( ASSOCIATED(S%FA(IMLOC)%RPNMDS) ) DEALLOCATE(S%FA(IMLOC)%RPNMDS) ENDIF ENDDO !$OMP END PARALLEL DO CALL GSTATS(1252,1) DEALLOCATE(ZRCVBUTFV) ENDIF ENDIF ENDIF ENDDO ! End of loop over zonal wavenumbers IF( S%LUSEFLT )THEN DEALLOCATE(ZCLONEA) DEALLOCATE(ZCLONES) ENDIF IF( LLP1 .AND. S%LUSEFLT ) THEN WRITE(NOUT,*) '=== SULEG: Finished SETUP_BUTTERFLY ===' ENDIF ENDIF CALL GSTATS(1801,3) IF(S%LUSE_BELUSOV) DEALLOCATE(F%RPNM) IF(C%LWRITE_LEGPOL) CALL WRITE_LEGPOL IF(C%LREAD_LEGPOL) CALL READ_LEGPOL ENDIF CALL GSTATS(1801,1) CALL GSTATS(140,1) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) CALL END_POL END SUBROUTINE SULEG END MODULE SULEG_MOD ectrans-1.8.0/src/trans/cpu/internal/spnorm_ctl_mod.F900000664000175000017500000000333515174631767023210 0ustar alastairalastair! (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. ! MODULE SPNORM_CTL_MOD CONTAINS SUBROUTINE SPNORM_CTL(PNORM,PSPEC,KFLD,KFLD_G,KVSET,KMASTER,PMET) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, MYPROC, MYSETV USE SPNORMD_MOD ,ONLY : SPNORMD USE SPNORMC_MOD ,ONLY : SPNORMC ! IMPLICIT NONE REAL(KIND=JPRB) , INTENT(OUT) :: PNORM(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFLD,KFLD_G INTEGER(KIND=JPIM) :: IVSET(KFLD_G) REAL(KIND=JPRB) :: ZMET(0:R%NSMAX) REAL(KIND=JPRB) :: ZSM(KFLD,D%NUMP) REAL(KIND=JPRB) :: ZGM(KFLD_G,0:R%NSMAX) ! ------------------------------------------------------------------ IF(PRESENT(KVSET)) THEN IVSET(:) = KVSET(:) ELSE IVSET(:) = MYSETV ENDIF IF(PRESENT(PMET)) THEN ZMET(:) = PMET(:) ELSE ZMET(:) = 1.0_JPRB ENDIF CALL SPNORMD(PSPEC,KFLD,ZMET,ZSM) CALL SPNORMC(ZSM,KFLD_G,IVSET,KMASTER,R%NSMAX,ZGM) IF(MYPROC == KMASTER) THEN PNORM(1:KFLD_G) = SUM(ZGM,DIM=2) PNORM(1:KFLD_G) = SQRT(PNORM(1:KFLD_G)) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE SPNORM_CTL END MODULE SPNORM_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/leinvad_mod.F900000664000175000017500000001122515174631767022447 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE LEINVAD_MOD CONTAINS SUBROUTINE LEINVAD(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KDGLU,PIA,PAOA1,PSOA1) !**** *LEINVAD* - Inverse Legendre transform. ! Purpose. ! -------- ! Inverse Legendre tranform of all variables(kernel). !** Interface. ! ---------- ! CALL LEINVAD(...) ! Explicit arguments : KM - zonal wavenumber (input-c) ! -------------------- KFC - number of fields to tranform (input-c) ! PIA - spectral fields ! for zonal wavenumber KM (input) ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (output) ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - calls SGEMVX (matrix multiply) ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From LEINVAD in IFS CY22R1 ! Modified ! 16/10/12 J.Hague : DR_HOOK round calls to DGEMM: ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRD, JPRM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G ! USE TPM_FLT ,ONLY : S USE BUTTERFLY_ALG_MOD,ONLY : MULT_BUTM USE ECTRANS_BLAS_MOD, ONLY : GEMM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KIFC INTEGER(KIND=JPIM), INTENT(IN) :: KDGLU INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT REAL(KIND=JPRB), INTENT(OUT) :: PIA(:,:) REAL(KIND=JPRB), INTENT(INOUT) :: PSOA1(:,:) REAL(KIND=JPRB), INTENT(INOUT) :: PAOA1(:,:) ! LOCAL VARIABLES INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, IOAD1, JK,JI INTEGER(KIND=JPIM) :: IFLD,ITHRESHOLD REAL(KIND=JPRB) :: ZBA((R%NSMAX-KM+2)/2,KIFC), ZBS((R%NSMAX-KM+3)/2,KIFC), ZC(KDGLU,KIFC) CHARACTER(LEN=1) :: CLX REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- !* 1.1 PREPARATIONS. CLX = 'S' IF (JPRD == JPRB) CLX = 'D' IA = 1+MOD(R%NSMAX-KM+2,2) IS = 1+MOD(R%NSMAX-KM+1,2) ILA = (R%NSMAX-KM+2)/2 ILS = (R%NSMAX-KM+3)/2 ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IOAD1 = 2*KF_OUT_LT IF(KM == 0)THEN ISKIP = 2 ELSE ISKIP = 1 ENDIF IF( KDGLU > 0 ) THEN ITHRESHOLD=S%ITHRESHOLD ! 1. +++++++++++++ anti-symmetric ! we need the transpose of C IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO JI=1,KDGLU ZC(JI,IFLD) = PAOA1(JK,ISL+JI-1) ENDDO ENDDO IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) CALL GEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,ZC,KDGLU,0._JPRB,ZBA,ILA) IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) ELSE CALL MULT_BUTM('T',S%FA(KMLOC)%YBUT_STRUCT_A,KIFC,ZC,ZBA) ENDIF IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO JI=1,ILA PIA(IA+1+(JI-1)*2,JK) = ZBA(JI,IFLD) ENDDO ENDDO ! 2. +++++++++++++ symmetric ! we need the transpose of C IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO JI=1,KDGLU ZC(JI,IFLD) = PSOA1(JK,ISL+JI-1) ENDDO ENDDO IF(ILS <= ITHRESHOLD .OR. .NOT.S%LUSEFLT ) THEN IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) CALL GEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,ZC,KDGLU,0._JPRB,ZBS,ILS) IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) ELSE CALL MULT_BUTM('T',S%FA(KMLOC)%YBUT_STRUCT_S,KIFC,ZC,ZBS) ENDIF IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO JI=1,ILS PIA(IS+1+(JI-1)*2,JK) = ZBS(JI,IFLD) ENDDO ENDDO ENDIF ! ! ------------------------------------------------------------------ END SUBROUTINE LEINVAD END MODULE LEINVAD_MOD ectrans-1.8.0/src/trans/cpu/internal/prfi1bad_mod.F900000664000175000017500000000577715174631767022534 0ustar alastairalastair! (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. ! MODULE PRFI1BAD_MOD CONTAINS SUBROUTINE PRFI1BAD(KM,PIA,PSPEC,KFIELDS,KFLDPTR) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D !**** *PRFI1* - Prepare spectral fields for inverse Legendre transform ! Purpose. ! -------- ! To extract the spectral fields for a specific zonal wavenumber ! and put them in an order suitable for the inverse Legendre . ! tranforms.The ordering is from NSMAX to KM for better conditioning. ! Elements 1,2 and NLCM(KM)+1 are zeroed in preparation for computing ! u,v and derivatives in spectral space. !** Interface. ! ---------- ! *CALL* *PRFI1BAD(...)* ! Explicit arguments : KM - zonal wavenumber ! ------------------ PIA - spectral components for transform ! PSPEC - spectral array ! KFIELDS - number of fields ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From PRFI1BAD in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KM,KFIELDS REAL(KIND=JPRB) ,INTENT(INOUT) :: PSPEC(:,:) REAL(KIND=JPRB) ,INTENT(IN) :: PIA(:,:) INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KFLDPTR(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, INM, IR, J, JFLD, ILCM, IOFF, IFLD ! ------------------------------------------------------------------ !* 1. EXTRACT FIELDS FROM SPECTRAL ARRAYS. ! -------------------------------------------------- ILCM = R%NSMAX+1-KM IOFF = D%NASM0(KM) IF(PRESENT(KFLDPTR)) THEN DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 IFLD = KFLDPTR(JFLD) DO J=1,ILCM INM = IOFF+(ILCM-J)*2 PSPEC(IFLD,INM ) = PSPEC(IFLD,INM ) + PIA(J+2,IR) PSPEC(IFLD,INM+1) = PSPEC(IFLD,INM+1) + PIA(J+2,II) ENDDO ENDDO ELSE DO J=1,ILCM INM = IOFF+(ILCM-J)*2 !DIR$ IVDEP !OCL NOVREC DO JFLD=1,KFIELDS IR = 2*(JFLD-1)+1 II = IR+1 PSPEC(JFLD,INM ) = PSPEC(JFLD,INM ) + PIA(J+2,IR) PSPEC(JFLD,INM+1) = PSPEC(JFLD,INM+1) + PIA(J+2,II) ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE PRFI1BAD END MODULE PRFI1BAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ftinvad_mod.F900000664000175000017500000000461515174631767022465 0ustar alastairalastair! (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. ! MODULE FTINVAD_MOD CONTAINS SUBROUTINE FTINVAD(PREEL,KFIELDS,KGL) !**** *FTINVAD - Inverse Fourier transform - adjoint ! Purpose. Routine for Fourier to Grid-point transform ! -------- !** Interface. ! ---------- ! CALL FTINVAD(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELDS - number of fields ! Method. ! ------- ! Externals. FFTW - FFT routine ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPIB, JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_FFTW ,ONLY : TW, EXEC_FFTW USE TPM_DIM ,ONLY : R ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL REAL(KIND=JPRB), INTENT(OUT) :: PREEL(:,:) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,JJ,JF,ILOEN INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN,ITYPE ! ------------------------------------------------------------------ ITYPE =-1 IGLG = D%NPTRLS(MYSETW)+KGL-1 ILOEN = G%NLOEN(IGLG)+R%NNOEXTZL IST = 2*(G%NMEN(IGLG)+1)+1 ILEN = ILOEN+3-IST IOFF = D%NSTAGTF(KGL)+1 IRLEN = ILOEN ICLEN = (IRLEN/2+1)*2 ! Change of metric (not in forward routine) DO JJ=1,ILOEN DO JF=1,KFIELDS PREEL(JF,IOFF-1+JJ) = PREEL(JF,IOFF-1+JJ)*ILOEN ENDDO ENDDO CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) DO JJ=1,ILEN DO JF=1,KFIELDS PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FTINVAD END MODULE FTINVAD_MOD ectrans-1.8.0/src/trans/cpu/internal/inv_trans_ctl_mod.F900000664000175000017500000002375115174631767023701 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE INV_TRANS_CTL_MOD CONTAINS SUBROUTINE INV_TRANS_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& & KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANS_CTL* - Control routine for inverse spectral transform. ! Purpose. ! -------- ! Control routine for the inverse spectral transform !** Interface. ! ---------- ! CALL INV_TRANS_CTL(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! 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. ! FSPGL_PROC - external procedure to be executed in fourier space ! before transposition ! PGP(:,:,:) - gridpoint fields (output) ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! vorticity : KF_UV_G fields ! divergence : KF_UV_G fields ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! N-S derivative of scalar fields : KF_SCALARS_G fields ! E-W derivative of u : KF_UV_G fields ! E-W derivative of v : KF_UV_G fields ! E-W derivative of scalar fields : KF_SCALARS_G fields ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NPROMATR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE LTINV_CTL_MOD ,ONLY : LTINV_CTL USE FTINV_CTL_MOD ,ONLY : FTINV_CTL ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) 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(:) REAL(KIND=JPRB) ,OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) EXTERNAL FSPGL_PROC OPTIONAL FSPGL_PROC REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB ! ------------------------------------------------------------------ ! Perform transform IF_GPB = 2*KF_UV_G+KF_SCALARS_G IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& & KVSETUV,KVSETSC) IBLKS=(IF_GPB-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF(LSCDERS) THEN IF_SCDERS = IF_SCALARS ELSE IF_SCDERS = 0 ENDIF IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS IF(LVORGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF(LDIVGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF_FS = IF_OUT_LT+IF_SCDERS IF(LUVDER) THEN IF_FS = IF_FS+2*IF_UV ENDIF IF_GP = 2*IF_UV_G+IF_SCALARS_G IOFFD = 0 IOFFU = 0 IOFFV = KF_UV_G IOFFUVD = 2*KF_UV_G+KF_SCALARS_G IOFFSC = 2*KF_UV_G IF(LVORGP) THEN IF_GP = IF_GP+IF_UV_G IOFFD = KF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LDIVGP) THEN IF_GP = IF_GP+IF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LSCDERS) THEN IF_GP = IF_GP+2*IF_SCALARS_G IOFFUVD =IOFFUVD+KF_SCALARS_G IOFFSCNS = IOFFSC+KF_SCALARS_G IOFFSCEW = IOFFSC+2*KF_SCALARS_G ENDIF IF(LUVDER) THEN IF_GP = IF_GP+2*IF_UV_G IOFFSCEW = IOFFSCEW+2*KF_UV_G ENDIF DO JFLD=1,IF_UV_G IOFF = 0 IF(LVORGP) THEN IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IF(LDIVGP) THEN IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G+IF_SCALARS_G IF(LSCDERS) THEN IOFF = IOFF+IF_SCALARS_G ENDIF IF(LUVDER) THEN IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_SCALARS_G IOFF = 2*IF_UV_G IF (LVORGP) IOFF = IOFF+IF_UV_G IF (LDIVGP) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LSCDERS) THEN IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LUVDER) THEN IOFF = IOFF+2*IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO CALL LTINV_CTL(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC,FSPGL_PROC=FSPGL_PROC) IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL FTINV_CTL(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL FTINV_CTL(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL FTINV_CTL(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ENDIF ENDDO ELSE ! No splitting of fields, transform done in one go CALL LTINV_CTL(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & &PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& &PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2,& &FSPGL_PROC=FSPGL_PROC) CALL FTINV_CTL(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE INV_TRANS_CTL END MODULE INV_TRANS_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/ltinv_ctlad_mod.F900000664000175000017500000000717715174631767023343 0ustar alastairalastair! (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. ! MODULE LTINV_CTLAD_MOD CONTAINS SUBROUTINE LTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2,& & KFLDPTRUV,KFLDPTRSC) !**** *LTINV_CTLAD* - Control routine for inverse Legandre transform - adj. ! Purpose. ! -------- ! Control routine for the inverse LEGENDRE transform !** Interface. ! ---------- ! CALL INV_TRANS_CTL(...) ! KF_OUT_LT - number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! KFLDPTRUV(:) - field pointer array for vor./div. ! KFLDPTRSC(:) - field pointer array for PSPSCALAR ! Method. ! ------- ! Externals. ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-06-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : LALLOPERM !USE TPM_DIM USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE TPM_DISTR ,ONLY : D USE LTINVAD_MOD ,ONLY : LTINVAD USE TRLTOM_MOD ,ONLY : TRLTOM IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS 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(:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) INTEGER(KIND=JPIM) :: JM,IM,IBLEN,ILEI2,IDIM1 ! ------------------------------------------------------------------ ILEI2 = 8*KF_UV + 2*KF_SCALARS + 2*KF_SCDERS IDIM1 = 2*KF_OUT_LT IBLEN = D%NLENGT0B*2*KF_OUT_LT IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) ENDIF CALL GSTATS(180,0) CALL TRLTOM(FOUBUF,FOUBUF_IN,2*KF_OUT_LT) CALL GSTATS(180,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF) CALL GSTATS(104,0) CALL GSTATS(1648,0) IF(KF_OUT_LT > 0) THEN ! Bug in gcc <= 10.2, see https://github.com/ecmwf-ifs/ectrans/issues/20 #if !(defined(__GFORTRAN__) && __GNUC__ == 10 && __GNUC_MINOR__ <= 2) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) #endif DO JM=1,D%NUMP IM = D%MYMS(JM) CALL LTINVAD(IM,JM,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,ILEI2,IDIM1,& & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) ENDDO #if !(defined(__GFORTRAN__) && __GNUC__ == 10 && __GNUC_MINOR__ <= 2) !$OMP END PARALLEL DO #endif ENDIF CALL GSTATS(1648,1) IF (.NOT.LALLOPERM) DEALLOCATE(FOUBUF_IN) CALL GSTATS(104,1) ! ------------------------------------------------------------------ END SUBROUTINE LTINV_CTLAD END MODULE LTINV_CTLAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ftinv_mod.F900000664000175000017500000000451115174631767022153 0ustar alastairalastair! (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. ! MODULE FTINV_MOD CONTAINS SUBROUTINE FTINV(PREEL,KFIELDS,KGL) !**** *FTINV - Inverse Fourier transform ! Purpose. Routine for Fourier to Grid-point transform ! -------- !** Interface. ! ---------- ! CALL FTINV(..) ! Explicit arguments : PREEL - Fourier/grid-point array ! -------------------- KFIELDS - number of fields ! Method. ! ------- ! Externals. FFTW - FFT routine ! ---------- ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti 01-04-24 : 2D model (NLOEN=1) ! D. Degrauwe (Feb 2012): Alternative extension zone (E') ! G. Mozdzynski (Oct 2014): support for FFTW transforms ! G. Mozdzynski (Jun 2015): Support alternative FFTs to FFTW ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TPM_FFTW ,ONLY : TW, EXEC_FFTW USE TPM_DIM ,ONLY : R IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS,KGL REAL(KIND=JPRB), INTENT(INOUT) :: PREEL(:,:) INTEGER(KIND=JPIM) :: IGLG,IST,ILEN,JJ,JF,IST1 INTEGER(KIND=JPIM) :: IOFF,IRLEN,ICLEN, ITYPE ! ------------------------------------------------------------------ ITYPE = 1 IGLG = D%NPTRLS(MYSETW)+KGL-1 IST = 2*(G%NMEN(IGLG)+1)+1 ILEN = G%NLOEN(IGLG)+R%NNOEXTZL+3-IST IST1=1 IF (G%NLOEN(IGLG)==1) IST1=0 DO JJ=IST1,ILEN DO JF=1,KFIELDS PREEL(JF,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRB ENDDO ENDDO IF (G%NLOEN(IGLG)>1) THEN IOFF=D%NSTAGTF(KGL)+1 IRLEN=G%NLOEN(IGLG)+R%NNOEXTZL ICLEN=(IRLEN/2+1)*2 CALL EXEC_FFTW(ITYPE,IRLEN,ICLEN,IOFF,KFIELDS,TW%LALL_FFTW,PREEL) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE FTINV END MODULE FTINV_MOD ectrans-1.8.0/src/trans/cpu/internal/uvtvd_mod.F900000664000175000017500000000765715174631767022213 0ustar alastairalastair! (C) Copyright 1991- ECMWF. ! (C) Copyright 1991- 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. ! MODULE UVTVD_MOD CONTAINS SUBROUTINE UVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) !**** *UVTVD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX. !** Interface. ! ---------- ! CALL UVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number ! -------------------- KFIELD - number of fields (levels) ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F !USE TPM_DISTR ! IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD INTEGER(KIND=JPIM), INTENT(IN) :: KM REAL(KIND=JPRB), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(OUT) :: PVOR(:,:),PDIV(:,:) REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:),PV (:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IN, IR, J, JN, ITMAX ! LOCAL REAL SCALARS REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZN(-1:R%NTMAX+3) ! ------------------------------------------------------------------ !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ ZKM = KM ITMAX = R%NTMAX ZN(KM-1:ITMAX+3) = REAL(F%RN(KM-1:ITMAX+3),JPRB) !* 1.1 SET N=KM-1 COMPONENT TO 0 FOR U AND V IN = F%NLTN(KM-1) DO J=1,2*KFIELD PU(IN,J) = 0.0_JPRB PV(IN,J) = 0.0_JPRB ENDDO !* 1.2 COMPUTE VORTICITY AND DIVERGENCE. IF(KM /= 0) THEN DO JN=KM,ITMAX IN = ITMAX+2-JN !DIR$ IVDEP !OCL NOVREC DO J=1,KFIELD IR = 2*J-1 II = IR+1 PVOR(IN,IR) = -ZKM*PV(IN,II)-& &ZN(JN)*PEPSNM(JN+1)*PU(IN-1,IR)+& &ZN(JN+1)*PEPSNM(JN)*PU(IN+1,IR) PVOR(IN,II) = +ZKM*PV(IN,IR)-& &ZN(JN)*PEPSNM(JN+1)*PU(IN-1,II)+& &ZN(JN+1)*PEPSNM(JN)*PU(IN+1,II) PDIV(IN,IR) = -ZKM*PU(IN,II)+& &ZN(JN)*PEPSNM(JN+1)*PV(IN-1,IR)-& &ZN(JN+1)*PEPSNM(JN)*PV(IN+1,IR) PDIV(IN,II) = +ZKM*PU(IN,IR)+& &ZN(JN)*PEPSNM(JN+1)*PV(IN-1,II)-& &ZN(JN+1)*PEPSNM(JN)*PV(IN+1,II) ENDDO ENDDO ELSE DO JN=KM,ITMAX IN = ITMAX+2-JN DO J=1,KFIELD IR = 2*J-1 PVOR(IN,IR) = -& &ZN(JN)*PEPSNM(JN+1)*PU(IN-1,IR)+& &ZN(JN+1)*PEPSNM(JN)*PU(IN+1,IR) PDIV(IN,IR) = & &ZN(JN)*PEPSNM(JN+1)*PV(IN-1,IR)-& &ZN(JN+1)*PEPSNM(JN)*PV(IN+1,IR) ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE UVTVD END MODULE UVTVD_MOD ectrans-1.8.0/src/trans/cpu/internal/fourier_outad_mod.F900000664000175000017500000000500315174631767023671 0ustar alastairalastair! (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. ! MODULE FOURIER_OUTAD_MOD CONTAINS SUBROUTINE FOURIER_OUTAD(PREEL, KFIELDS, KGL) !**** *FOURIER_OUTAD* - Copy fourier data from local array to buffer - adjoint ! Purpose. ! -------- ! Routine for copying fourier data from local array to buffer !** Interface. ! ---------- ! CALL FOURIER_OUTAD(...) ! Explicit arguments : PREEL - local fourier/GP array ! -------------------- KFIELDS - number of fields ! KGL - local index of latitude we are currently on ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND1, ONLY : JPIM, JPRB USE TPM_DISTR, ONLY : D, MYSETW USE TPM_TRANS, ONLY : FOUBUF_IN USE TPM_GEOMETRY, ONLY : G IMPLICIT NONE REAL(KIND=JPRB), INTENT(OUT) :: PREEL(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KGL INTEGER(KIND=JPIM) :: JM, JF, IGLG, IPROC, IR, II, ISTA ! ------------------------------------------------------------------ ! Determine global latitude index corresponding to local latitude index KGL IGLG = D%NPTRLS(MYSETW) + KGL - 1 ! Loop over all zonal wavenumbers relevant for this latitude DO JM = 0, G%NMEN(IGLG) ! Get the member of the W-set responsible for this zonal wavenumber in the "m" representation IPROC = D%NPROCM(JM) ! Compute offset in FFT work array PREEL corresponding to wavenumber JM and latitude KGL IR = 2 * JM + 1 + D%NSTAGTF(KGL) II = 2 * JM + 2 + D%NSTAGTF(KGL) ! Compute offset for extraction of the fields from the l-to-m transposition buffer, FOUBUF, IN ISTA = (D%NSTAGT1B(D%MSTABF(IPROC)) + D%NPNTGTB0(JM,KGL)) * 2 * KFIELDS ! Copy all fields from l-to-m transposition buffer to FFT work array DO JF = 1, KFIELDS PREEL(JF,IR) = FOUBUF_IN(ISTA+2*JF-1) PREEL(JF,II) = FOUBUF_IN(ISTA+2*JF) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FOURIER_OUTAD END MODULE FOURIER_OUTAD_MODectrans-1.8.0/src/trans/cpu/internal/asre1b_mod.F900000664000175000017500000000605615174631767022210 0ustar alastairalastair! (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. ! MODULE ASRE1B_MOD CONTAINS SUBROUTINE ASRE1B(KFIELD,KM,KMLOC,PAOA,PSOA) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF_IN USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D !**** *ASRE1B* - Recombine antisymmetric and symmetric parts ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *ASRE1B(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields (input-c) ! KM - zonal wavenumber(input-c) ! KMLOC - local version of KM (input-c) ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM (input) ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM (input) ! Implicit arguments : FOUBUF_IN - output buffer (output) ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1B in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD,KM,KMLOC REAL(KIND=JPRB), INTENT(IN) :: PSOA(:,:) REAL(KIND=JPRB), INTENT(IN) :: PAOA(:,:) ! LOCAL INTEGERS INTEGER(KIND=JPIM) :: ISL, IGLS, JFLD, JGL ,IPROC, IPROCS, IDGNH INTEGER(KIND=JPIM) :: ISTAN(R%NDGNH),ISTAS(R%NDGNH) ! ------------------------------------------------------------------ !* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. ! --------------------------------------------------- ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IDGNH = R%NDGNH !* 1.2 RECOMBINE DO JGL=ISL,IDGNH IPROC = D%NPROCL(JGL) ISTAN(JGL) = (D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*2*KFIELD IGLS = R%NDGL+1-JGL IPROCS = D%NPROCL(IGLS) ISTAS(JGL) = (D%NSTAGT0B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*2*KFIELD ENDDO DO JGL=ISL,IDGNH !OCL NOVREC DO JFLD=1,2*KFIELD FOUBUF_IN(ISTAN(JGL)+JFLD) = PAOA(JFLD,JGL)+PSOA(JFLD,JGL) FOUBUF_IN(ISTAS(JGL)+JFLD) = PSOA(JFLD,JGL)-PAOA(JFLD,JGL) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE ASRE1B END MODULE ASRE1B_MOD ectrans-1.8.0/src/trans/cpu/internal/gpnorm_trans_ctlad_mod.F900000664000175000017500000002104615174631767024707 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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. ! MODULE GPNORM_TRANS_CTLAD_MOD CONTAINS SUBROUTINE GPNORM_TRANS_CTLAD(PGP,KFIELDS,KPROMA,PAVE,PW) !**** *GPNORM_TRANS_CTLAD* - calculate grid-point norms (Adjoint version) ! Note: This only does adjoint of the norm average ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL GPNORM_TRANS_CTLAD(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! ! Author. ! ------- ! Filip Vana, after GPNORM_TRANS_CTL_MOD ! (c) ECMWF, 16-Aug-2024 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD !ifndef INTERFACE USE TPM_GEN ,ONLY : NOUT USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LGPNORM, NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRCIDS, NPRTRV, NPRTRW, MYSETV, MYSETW USE TPM_GEOMETRY ,ONLY : G USE TRLTOG_MOD ,ONLY : TRLTOG USE SET2PE_MOD ,ONLY : SET2PE USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, JP_BLOCKING_STANDARD, & & MPL_BROADCAST USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA REAL(KIND=JPRD) ,INTENT(IN) :: PW(R%NDGL) !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE INTEGER(KIND=JPIM) :: IUBOUND(4) INTEGER(KIND=JPIM) :: IVSET(KFIELDS) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IVSETG(:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZGTF(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVE(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZAVEG(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZSND(:) REAL(KIND=JPRD),ALLOCATABLE :: ZRCV(:) INTEGER(KIND=JPIM) :: J,JGL,IGL,JL,JF,IF_GP,IF_SCALARS_G,IF_FS,JSETV,JSETW,IWLATS INTEGER(KIND=JPIM) :: IPROC,ITAG,ILEN,ILENR,IBEG,IEND,IND ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTLAD',0,ZHOOK_HANDLE) ! Set defaults NPROMA = KPROMA NGPBLKS = (D%NGPTOT-1)/NPROMA+1 ! Consistency checks IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('GPNORM_TRANS_CTLAD:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFIELDS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLAD:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFIELDS CALL ABORT_TRANS('GPNORM_TRANS_CTLAD:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'GPNORM_TRANS_CTLAD:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('GPNORM_TRANS_CTLAD:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF_GP=KFIELDS IF_SCALARS_G=0 IF_FS=0 DO J=1,KFIELDS IVSET(J)=MOD(J-1,NPRTRV)+1 IF(IVSET(J)==MYSETV)THEN IF_FS=IF_FS+1 ENDIF ENDDO ALLOCATE(IVSETS(NPRTRV)) IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 ENDDO ALLOCATE(IVSETG(NPRTRV,MAXVAL(IVSETS(:)))) IVSETG(:,:)=0 IVSETS(:)=0 DO J=1,KFIELDS IVSETS(IVSET(J))=IVSETS(IVSET(J))+1 IVSETG(IVSET(J),IVSETS(IVSET(J)))=J ENDDO ALLOCATE(ZGTF(IF_FS,D%NLENGTF)) IF (SIZE(ZGTF) > 0) ZGTF(:,:)=0._JPRB ! force allocation right here, not inside an omp region below IBEG=1 IEND=D%NDGL_FS ALLOCATE(ZAVE(IF_FS,IBEG:IEND)) ZAVE(1:IF_FS,IBEG:IEND)=0._JPRB ! IT IS IMPORTANT THAT SUMS ARE NOW DONE IN LATITUDE ORDER ALLOCATE(ZAVEG(R%NDGL,KFIELDS)) ZAVEG(:,:)=0.0_JPRB IF( MYSETW == 1 .AND. MYSETV == 1 )THEN DO JGL=R%NDGL,1,-1 ZAVEG(JGL,:)=ZAVEG(JGL,:)+PAVE(:) ENDDO PAVE(:)=0.0_JPRB ENDIF ! RECEIVE ABOVE FROM OTHER NPRTRV SETS FOR SAME LATS BUT DIFFERENT FIELDS ITAG=1231 CALL GSTATS(815,0) ! Following is targeted and thus more economic way replacing MPL_BROADCAST. ! This implies the line bellow gives the same result but for higher cost: ! IF (NPRTRV*NPRTRW > 1) & ! & CALL MPL_BROADCAST (ZAVEG,ITAG,1,CDSTRING='GPNORMAD_BRDCST') ! FINALLY RECEIVE CONTRIBUTIONS FROM OTHER NPRTRW SETS IF( MYSETV == 1 )THEN IF( MYSETW == 1 )THEN DO JSETW=2,NPRTRW IWLATS=D%NULTPP(JSETW) ILEN=IWLATS*KFIELDS IF(ILEN > 0 )THEN CALL SET2PE(IPROC,0,0,JSETW,1) ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(JSETW) + JGL - 1 IND=IND+1 ZSND(IND)=ZAVEG(IGL,JF) ENDDO ENDDO CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTLAD:W') DEALLOCATE(ZSND) ENDIF ENDDO ELSE IWLATS=D%NULTPP(MYSETW) ILEN=IWLATS*KFIELDS IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,1,1) ALLOCATE(ZRCV(ILEN)) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& & KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,& & CDSTRING='GPNORM_TRANS_CTLAD:W') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTLAD:ILENR /= ILEN') ENDIF IND=0 DO JF=1,KFIELDS DO JGL=IBEG,IWLATS IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,JF)=ZRCV(IND) ENDDO ENDDO DEALLOCATE(ZRCV) ENDIF ENDIF ENDIF IF ( MYSETV == 1 ) THEN DO JSETV=2,NPRTRV ILEN=D%NDGL_FS*IVSETS(JSETV) IF(ILEN > 0)THEN ALLOCATE(ZSND(ILEN)) IND=0 DO JF=1,IVSETS(JSETV) DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZSND(IND) = ZAVEG(IGL,IVSETG(JSETV,JF)) ENDDO ENDDO CALL SET2PE(IPROC,0,0,MYSETW,JSETV) CALL MPL_SEND(ZSND(:),KDEST=NPRCIDS(IPROC),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,CDSTRING='GPNORM_TRANS_CTLAD:V') DEALLOCATE(ZSND) ENDIF ENDDO ELSE ILEN=D%NDGL_FS*IVSETS(MYSETV) IF(ILEN > 0)THEN CALL SET2PE(IPROC,0,0,MYSETW,1) ALLOCATE(ZRCV(ILEN)) CALL MPL_RECV(ZRCV(:),KSOURCE=NPRCIDS(IPROC),KTAG=ITAG,& & KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR, & & CDSTRING='GPNORM_TRANS_CTLAD:V') IF(ILENR /= ILEN)THEN CALL ABOR1('GPNORM_TRANS_CTLAD:ILENR /= ILEN') ENDIF IND=0 DO JF=1,IF_FS DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 IND=IND+1 ZAVEG(IGL,IVSETG(MYSETV,JF))= ZRCV(IND) ENDDO ENDDO DEALLOCATE(ZRCV) ENDIF ENDIF CALL GSTATS(815,1) DO JF=IF_FS,1,-1 DO JGL=IEND,IBEG,-1 IGL = D%NPTRLS(MYSETW) + JGL - 1 ZAVE(JF,JGL)=ZAVE(JF,JGL)+ZAVEG(IGL,IVSETG(MYSETV,JF)) ENDDO ENDDO !ZAVEG(:,:)=0.0_JPRB IF( IF_FS > 0 )THEN DO JGL=IBEG,IEND IGL = D%NPTRLS(MYSETW) + JGL - 1 DO JF=1,IF_FS ZAVE(JF,JGL)=ZAVE(JF,JGL)*REAL(PW(IGL),JPRB)/G%NLOEN(IGL) ENDDO ENDDO ! FIRST DO SUMS IN EACH FULL LATITUDE CALL GSTATS(1429,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JGL,IGL,JF,JL) DO JGL=IEND,IBEG,-1 IGL = D%NPTRLS(MYSETW) + JGL - 1 !CDIR NOLOOPCHG DO JF=IF_FS,1,-1 !DIR$ NEXTSCALAR DO JL=G%NLOEN(IGL),1,-1 ZGTF(JF,D%NSTAGTF(JGL)+JL)= ZGTF(JF,D%NSTAGTF(JGL)+JL) & & +ZAVE(JF,JGL) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1429,1) ENDIF LGPNORM=.TRUE. CALL TRLTOG(ZGTF,IF_FS,IF_GP,IF_SCALARS_G,IVSET,PGP=PGP) LGPNORM=.FALSE. DEALLOCATE(ZGTF) DEALLOCATE(ZAVE) DEALLOCATE(ZAVEG) DEALLOCATE(IVSETS) DEALLOCATE(IVSETG) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS_CTLAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANS_CTLAD END MODULE GPNORM_TRANS_CTLAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ledirad_mod.F900000664000175000017500000001166215174631767022436 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- 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. ! MODULE LEDIRAD_MOD CONTAINS SUBROUTINE LEDIRAD(KM,KMLOC,KFC,KIFC,KDGLU,KLED2,PAIA,PSIA,POA1) !**** *LEDIRAD* - Direct Legendre transform. ! Purpose. ! -------- ! Direct Legendre tranform of state variables. !** Interface. ! ---------- ! CALL LEDIRAD(...) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFC - number of field to transform ! PAIA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSIA - symmetric part of Fourier ! fields for zonal wavenumber KM ! POA1 - spectral ! fields for zonal wavenumber KM ! PLEPO - Legendre polonomials ! Implicit arguments : None. ! -------------------- ! Method. ! ------- ! Externals. MXMAOP - matrix multiply ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-01-28 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 93-03-19 D. Giard - NTMAX instead of NSMAX ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! Modified ! 16/10/12 J.Hague : DR_HOOK round calls to DGEMM: ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRD, JPRM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G ! USE TPM_FLT ,ONLY : S USE TPM_FIELDS ,ONLY : F USE BUTTERFLY_ALG_MOD ,ONLY: MULT_BUTM USE ECTRANS_BLAS_MOD, ONLY : GEMM IMPLICIT NONE ! DUMMY ARGUMENTS INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KIFC INTEGER(KIND=JPIM), INTENT(IN) :: KDGLU INTEGER(KIND=JPIM), INTENT(IN) :: KLED2 REAL(KIND=JPRB), INTENT(OUT) :: PSIA(:,:), PAIA(:,:) REAL(KIND=JPRB), INTENT(IN) :: POA1(:,:) INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, J, JK,JGL,J1 INTEGER(KIND=JPIM) :: IFLD,ITHRESHOLD REAL(KIND=JPRB) :: ZB(KDGLU,KIFC), ZCA((R%NTMAX-KM+2)/2,KIFC), ZCS((R%NTMAX-KM+3)/2,KIFC) CHARACTER(LEN=1) :: CLX REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- !* 1.1 PREPARATIONS. CLX = 'S' IF (JPRD == JPRB) CLX = 'D' IA = 1+MOD(R%NTMAX-KM+2,2) IS = 1+MOD(R%NTMAX-KM+1,2) ILA = (R%NTMAX-KM+2)/2 ILS = (R%NTMAX-KM+3)/2 ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IF(KM == 0)THEN ISKIP = 2 DO JGL=ISL,R%NDGNH DO J1=2,KFC,2 PSIA(J1,JGL)=0.0_JPRB PAIA(J1,JGL)=0.0_JPRB ENDDO ENDDO ELSE ISKIP = 1 ENDIF IF (KIFC > 0 .AND. KDGLU > 0 ) THEN ITHRESHOLD=S%ITHRESHOLD !* 1. ANTISYMMETRIC PART. IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILA ZCA(J,IFLD) = POA1(IA+(J-1)*2,JK) ENDDO ENDDO IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) CALL GEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,ZCA,ILA,0._JPRB,ZB,KDGLU) IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) ELSE CALL MULT_BUTM('N',S%FA(KMLOC)%YBUT_STRUCT_A,KIFC,ZCA,ZB) ENDIF IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,KDGLU PAIA(JK,ISL+J-1) = ZB(J,IFLD)*REAL(F%RW(ISL+J-1),JPRB) ENDDO ENDDO !* 1.3 SYMMETRIC PART. IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILS ZCS(J,IFLD) = POA1(IS+(J-1)*2,JK) ENDDO ENDDO IF(ILS <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) CALL GEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRD,S%FA(KMLOC)%RPNMS,KDGLU,ZCS,ILS,0._JPRD,ZB,KDGLU) IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) ELSE CALL MULT_BUTM('N',S%FA(KMLOC)%YBUT_STRUCT_S,KIFC,ZCS,ZB) ENDIF IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,KDGLU PSIA(JK,ISL+J-1) = ZB(J,IFLD)*REAL(F%RW(ISL+J-1),JPRB) ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE LEDIRAD END MODULE LEDIRAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ldfou2_mod.F900000664000175000017500000000513415174631767022222 0ustar alastairalastair! (C) Copyright 1991- ECMWF. ! (C) Copyright 1991- 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. ! MODULE LDFOU2_MOD CONTAINS SUBROUTINE LDFOU2(KM,KF_UV,PAIA,PSIA) !**** *LDFOU2* - Division by a*cos(theta) of u and v ! Purpose. ! -------- ! In Fourier space divide u and v by a*cos(theta). !** Interface. ! ---------- ! CALL LDFOU2(KM,PAIA,PSIA) ! Explicit arguments : ! -------------------- KM - zonal wavenumber ! PAIA - antisymmetric fourier fields ! PSIA - symmetric fourierfields ! Implicit arguments : RACTHE - 1./(a*cos(theta)) ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! Modified : 94-04-06 R. El Khatib - Full-POS configuration 'P' ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Message Passing option added ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F ! IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV REAL(KIND=JPRB) ,INTENT(INOUT) :: PSIA(:,:), PAIA(:,:) ! LOCAL REAL SCALARS REAL(KIND=JPRB) :: ZACTHE ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: J, JGL ,IFLD ,ISL ! ------------------------------------------------------------------ !* 1. DIVIDE U V BY A*COS(THETA) ! -------------------------- ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IFLD = 4*KF_UV !* 1.1 U AND V DO JGL=ISL,R%NDGNH ZACTHE = REAL(F%RACTHE(JGL),JPRB) DO J=1,IFLD PAIA(J,JGL) = PAIA(J,JGL)*ZACTHE PSIA(J,JGL) = PSIA(J,JGL)*ZACTHE ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE LDFOU2 END MODULE LDFOU2_MOD ectrans-1.8.0/src/trans/cpu/internal/vd2uv_mod.F900000664000175000017500000000767315174631767022107 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE VD2UV_MOD CONTAINS SUBROUTINE VD2UV(KM,KMLOC,KF_UV,KLEI2,PSPVOR,PSPDIV,PU,PV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_CONSTANTS ,ONLY : RA USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE PREPSNM_MOD ,ONLY : PREPSNM USE PRFI1B_MOD ,ONLY : PRFI1B USE VDTUV_MOD ,ONLY : VDTUV !**** *VD2UV* - U and V from Vor/div ! ! Purpose. ! -------- ! !** Interface. ! ---------- ! *CALL* *VD2UV(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PU(:,:) - spectral U (out) ! PV(:,:) - spectral V (out) ! Implicit arguments : ! Method. ! ------- ! Externals. ! ---------- ! PREPSNM - prepare REPSNM for wavenumber KM ! PRFI1B - prepares the spectral fields ! VDTUV - compute u and v from vorticity and divergence ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 ! ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KLEI2 REAL(KIND=JPRB) , INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) , INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PU(:,:) REAL(KIND=JPRB) , INTENT(OUT) :: PV(:,:) REAL(KIND=JPRB) :: ZIA(R%NLEI1,KLEI2) REAL(KIND=JPRB) :: ZEPSNM(0:R%NTMAX+2),ZA_R INTEGER(KIND=JPIM) :: JFLD,ILCM INTEGER(KIND=JPIM) :: IVORL,IVORU,IDIVL,IDIVU,IUL,IUU,IVL,IVU,II,IR,INM,J INTEGER(KIND=JPIM) :: IFIRST, ILAST, IOFF REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- IF (LHOOK) CALL DR_HOOK('VD2UV_MOD',0,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !* 1. PREPARE ZEPSNM. ! --------------- CALL PREPSNM(KM,KMLOC,ZEPSNM) ! ------------------------------------------------------------------ !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- IFIRST = 1 ILAST = 4*KF_UV IF (KF_UV > 0) THEN IVORL = 1 IVORU = 2*KF_UV IDIVL = 2*KF_UV+1 IDIVU = 4*KF_UV IUL = 4*KF_UV+1 IUU = 6*KF_UV IVL = 6*KF_UV+1 IVU = 8*KF_UV CALL PRFI1B(KM,ZIA(:,IVORL:IVORU),PSPVOR,KF_UV) CALL PRFI1B(KM,ZIA(:,IDIVL:IDIVU),PSPDIV,KF_UV) CALL VDTUV(KM,KF_UV,ZEPSNM,ZIA(:,IVORL:IVORU),ZIA(:,IDIVL:IDIVU),& & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU)) ILCM = R%NSMAX+1-KM IOFF = D%NASM0(KM) ZA_R = 1.0_JPRB/REAL(RA,JPRB) DO J=1,ILCM INM = IOFF+(ILCM-J)*2 DO JFLD=1,KF_UV IR = 2*(JFLD-1)+1 II = IR+1 PU(JFLD,INM ) = ZIA(J+2,IR+IUL-1)*ZA_R PU(JFLD,INM+1) = ZIA(J+2,II+IUL-1)*ZA_R PV(JFLD,INM ) = ZIA(J+2,IR+IVL-1)*ZA_R PV(JFLD,INM+1) = ZIA(J+2,II+IVL-1)*ZA_R ENDDO ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('VD2UV_MOD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE VD2UV END MODULE VD2UV_MOD ectrans-1.8.0/src/trans/cpu/internal/spnsdead_mod.F900000664000175000017500000000576015174631767022635 0ustar alastairalastair! (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. ! MODULE SPNSDEAD_MOD CONTAINS SUBROUTINE SPNSDEAD(KM,KF_SCALARS,PEPSNM,PF,PNSD) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F !**** *SPNSDEAD* - Compute North-South derivative in spectral space ! Purpose. ! -------- ! In Laplace space compute the the North-south derivative !** Interface. ! ---------- ! CALL SPNSDEAD(...) ! Explicit arguments : ! -------------------- ! KM -zonal wavenumber (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PF (NLEI1,2*KF_SCALARS) - input field (input) ! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : YOMLAP ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From SPNSDEAD in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(INOUT) :: PF(:,:) REAL(KIND=JPRB), INTENT(IN) :: PNSD(:,:) INTEGER(KIND=JPIM) :: IJ, ISKIP, J, JN,JI,ISMAX REAL(KIND=JPRB) :: ZEPSNM(-1:R%NSMAX+4) REAL(KIND=JPRB) :: ZN(-1:R%NTMAX+4) ! ------------------------------------------------------------------ !* 1. COMPUTE NORTH SOUTH DERIVATIVE. ! ------------------------------- !* 1.1 COMPUTE ISMAX = R%NSMAX DO JN=KM-1,ISMAX+2 IJ = ISMAX+3-JN ZN(IJ) = REAL(F%RN(JN),JPRB) IF( JN >= 0 ) ZEPSNM(IJ) = PEPSNM(JN) ENDDO ZN(0) = REAL(F%RN(ISMAX+3),JPRB) IF(KM == 0) THEN ISKIP = 2 ELSE ISKIP = 1 ENDIF !cdir loopchg !cdir select(vector) DO J=1,2*KF_SCALARS,ISKIP DO JI=2,ISMAX+3-KM PF(JI+1,J) = PF(JI+1,J)-ZN(JI+1)*ZEPSNM(JI) *PNSD(JI,J) PF(JI-1,J) = PF(JI-1,J)+ZN(JI-2)*ZEPSNM(JI-1)*PNSD(JI,J) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE SPNSDEAD END MODULE SPNSDEAD_MOD ectrans-1.8.0/src/trans/cpu/internal/prfi2b_mod.F900000664000175000017500000000570115174631767022213 0ustar alastairalastair! (C) Copyright 1990- ECMWF. ! (C) Copyright 1990- 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. ! MODULE PRFI2B_MOD CONTAINS SUBROUTINE PRFI2B(KFIELD,KM,KMLOC,PAIA,PSIA) !**** *PRFI2B* - Prepare input work arrays for direct transform ! Purpose. ! -------- ! To extract the Fourier fields for a specific zonal wavenumber ! and put them in an order suitable for the direct Legendre ! tranforms, i.e. split into symmetric and anti-symmetric part. !** Interface. ! ---------- ! *CALL* *PRFI2B(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM ! Implicit arguments : FOUBUF in TPM_TRANS ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 90-07-01 ! MPP Group: 95-10-01 Support for Distributed Memory version ! Modified : 04/06/99 D.Salmond : change order of AIA and SIA ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD,KM,KMLOC REAL(KIND=JPRB) , INTENT(OUT) :: PSIA(:,:), PAIA(:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IGLS, ISL, ISTAN, ISTAS, JF, JGL ! ------------------------------------------------------------------ !* 1. EXTRACT SYM./ANTISYM. FIELDS FROM FOURIER ARRAY. ! ------------------------------------------------ ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) DO JGL=ISL,R%NDGNH IGLS = R%NDGL+1-JGL ISTAN = (D%NSTAGT1B(D%NPROCL(JGL) )+D%NPNTGTB1(KMLOC,JGL ))*2*KFIELD ISTAS = (D%NSTAGT1B(D%NPROCL(IGLS))+D%NPNTGTB1(KMLOC,IGLS))*2*KFIELD !DIR$ IVDEP !OCL NOVREC DO JF=1,KFIELD*2 PSIA(JF,JGL) = FOUBUF(ISTAN+JF)+FOUBUF(ISTAS+JF) PAIA(JF,JGL) = FOUBUF(ISTAN+JF)-FOUBUF(ISTAS+JF) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE PRFI2B END MODULE PRFI2B_MOD ectrans-1.8.0/src/trans/cpu/internal/vd2uv_ctl_mod.F900000664000175000017500000000400615174631767022734 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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. ! MODULE VD2UV_CTL_MOD CONTAINS SUBROUTINE VD2UV_CTL(KF_UV,PSPVOR,PSPDIV,PU,PV) !**** *VD2UV_CTL* - Control routine for going from vor/div to spectral U and V. ! Purpose. ! -------- ! Control routine for computing spectral U (u*cos(theta)) and V !** Interface. ! ---------- ! CALL INV_TRANS_CTL(...) ! KF_UV - local number of spectral u-v fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PU(:,:) - U (out) ! PV(:,:) - V (out) ! Method. ! ------- ! Externals. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : July 2015 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DISTR ,ONLY : D USE VD2UV_MOD ,ONLY : VD2UV IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV REAL(KIND=JPRB),INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB),INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB),INTENT(OUT) :: PU(:,:) REAL(KIND=JPRB),INTENT(OUT) :: PV(:,:) INTEGER(KIND=JPIM) :: JM,IM,ILEI2 ! ------------------------------------------------------------------ CALL GSTATS(102,0) ILEI2 = 8*KF_UV CALL GSTATS(1647,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JM,IM) DO JM=1,D%NUMP IM = D%MYMS(JM) CALL VD2UV(IM,JM,KF_UV,ILEI2,PSPVOR,PSPDIV,PU,PV) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1647,1) CALL GSTATS(102,1) ! ------------------------------------------------------------------ END SUBROUTINE VD2UV_CTL END MODULE VD2UV_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/fscad_mod.F900000664000175000017500000000737415174631767022117 0ustar alastairalastair! (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. ! MODULE FSCAD_MOD CONTAINS SUBROUTINE FSCAD(KGL,KF_UV,KF_SCALARS,KF_SCDERS,& & PUV,PSCALAR,PNSDERS,PEWDERS,PUVDERS) !**** *FSCAD - Division by a*cos(theta), east-west derivatives - adjoint ! Purpose. ! -------- ! In Fourier space divide u and v and all north-south ! derivatives by a*cos(theta). Also compute east-west derivatives ! of u,v,thermodynamic, passiv scalar variables and surface ! pressure. !** Interface. ! ---------- ! CALL FSCAD(..) ! Explicit arguments : PUV - u and v ! -------------------- PSCALAR - scalar valued varaibles ! PNSDERS - N-S derivative of S.V.V. ! PEWDERS - E-W derivative of S.V.V. ! PUVDERS - E-W derivative of u and v ! Method. ! ------- ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 (From SC2FSC) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_TRANS ,ONLY : LUVDER USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_FIELDS ,ONLY : F USE TPM_GEOMETRY ,ONLY : G ! IMPLICIT NONE INTEGER(KIND=JPIM) , INTENT(IN) :: KGL,KF_UV,KF_SCALARS,KF_SCDERS REAL(KIND=JPRB) , INTENT(INOUT) :: PUV(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PSCALAR(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PNSDERS(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PEWDERS(:,:) REAL(KIND=JPRB) , INTENT(INOUT) :: PUVDERS(:,:) REAL(KIND=JPRB) :: ZACHTE,ZMUL INTEGER(KIND=JPIM) :: IMEN,ISTAGTF INTEGER(KIND=JPIM) :: JLON,JF,IGLG,II,IR,JM ! ------------------------------------------------------------------ IGLG = D%NPTRLS(MYSETW)+KGL-1 ZACHTE = REAL(F%RACTHE(IGLG),JPRB) IMEN = G%NMEN(IGLG) ISTAGTF = D%NSTAGTF(KGL) ! ------------------------------------------------------------------ !* 2. EAST-WEST DERIVATIVES ! --------------------- !* 2.1 U AND V. IF(LUVDER)THEN DO JM=0,IMEN IR = ISTAGTF+2*JM+1 II = IR+1 ZMUL = ZACHTE*JM DO JF=1,2*KF_UV PUV(JF,II) = PUV(JF,II) - PUVDERS(JF,IR)*ZMUL PUV(JF,IR) = PUV(JF,IR) + PUVDERS(JF,II)*ZMUL ! PUVDERS(JF,IR) = _ZERO_ ! PUVDERS(JF,II) = _ZERO_ ENDDO ENDDO ENDIF !* 2.2 SCALAR VARIABLES IF(KF_SCDERS > 0)THEN DO JM=0,IMEN IR = ISTAGTF+2*JM+1 II = IR+1 ZMUL = ZACHTE*JM DO JF=1,KF_SCALARS PSCALAR(JF,II) = PSCALAR(JF,II) - PEWDERS(JF,IR)*ZMUL PSCALAR(JF,IR) = PSCALAR(JF,IR) + PEWDERS(JF,II)*ZMUL ! PEWDERS(JF,IR) = _ZERO_ ! PEWDERS(JF,II) = _ZERO_ ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ !* 1. DIVIDE U V AND N-S DERIVATIVES BY A*COS(THETA) ! ---------------------------------------------- !* 1.1 U AND V. IF(KF_UV > 0) THEN DO JLON=ISTAGTF+1,ISTAGTF+2*(IMEN+1) DO JF=1,2*KF_UV PUV(JF,JLON) = PUV(JF,JLON)*ZACHTE ENDDO ENDDO ENDIF !* 1.2 N-S DERIVATIVES IF(KF_SCDERS > 0)THEN DO JLON=ISTAGTF+1,ISTAGTF+2*(IMEN+1) DO JF=1,KF_SCALARS PNSDERS(JF,JLON) = PNSDERS(JF,JLON)*ZACHTE ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE FSCAD END MODULE FSCAD_MOD ectrans-1.8.0/src/trans/cpu/internal/ftdir_ctl_mod.F900000664000175000017500000001300415174631767022774 0ustar alastairalastair! (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. ! MODULE FTDIR_CTL_MOD CONTAINS SUBROUTINE FTDIR_CTL(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS, & & KVSETUV,KVSETSC,KPTRGP,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *FTDIR_CTL - Direct Fourier transform control ! Purpose. Control routine for Grid-point to Fourier transform ! -------- !** Interface. ! ---------- ! CALL FTDIR_CTL(..) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! PGP - gridpoint array ! KVSETUV - "B" set in spectral/fourier space for ! u and v variables ! KVSETSC - "B" set in spectral/fourier space for ! scalar variables ! KPTRGP - pointer array to fields in gridpoint space ! Method. ! ------- ! Externals. TRGTOL - transposition routine ! ---------- FOURIER_OUT - copy fourier data to Fourier buffer ! FTDIR - fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! R. El Khatib 01-Jun-2022 contiguous pointer ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NSTACK_MEMORY_TR USE TPM_TRANS ,ONLY : FOUBUF_IN USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE TRGTOL_MOD ,ONLY : TRGTOL USE FOURIER_OUT_MOD ,ONLY : FOURIER_OUT USE FTDIR_MOD ,ONLY : FTDIR ! IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM),INTENT(IN) :: KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3A(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC3B(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETSC2(:) 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(:,:,:) ! Local variables REAL(KIND=JPRB),TARGET :: ZGTF_STACK(KF_FS*MIN(1,MAX(0,NSTACK_MEMORY_TR)),D%NLENGTF) REAL(KIND=JPRB),TARGET, ALLOCATABLE :: ZGTF_HEAP(:,:) REAL(KIND=JPRB),POINTER, CONTIGUOUS :: ZGTF(:,:) INTEGER(KIND=JPIM) :: IST,JGL,IBLEN INTEGER(KIND=JPIM) :: IVSETUV(KF_UV_G) INTEGER(KIND=JPIM) :: IVSETSC(KF_SCALARS_G) INTEGER(KIND=JPIM) :: IVSET(KF_GP) INTEGER(KIND=JPIM) :: IFGP2,IFGP3A,IFGP3B,IOFF,J3 ! ------------------------------------------------------------------ ! Field distribution in Spectral/Fourier space IF(PRESENT(KVSETUV)) THEN IVSETUV(:) = KVSETUV(:) ELSE IVSETUV(:) = -1 ENDIF IVSETSC(:) = -1 IF(PRESENT(KVSETSC)) THEN IVSETSC(:) = KVSETSC(:) ELSE IOFF=0 IF(PRESENT(KVSETSC2)) THEN IFGP2=UBOUND(KVSETSC2,1) IVSETSC(1:IFGP2)=KVSETSC2(:) IOFF=IOFF+IFGP2 ENDIF IF(PRESENT(KVSETSC3A)) THEN IFGP3A=UBOUND(KVSETSC3A,1) DO J3=1,UBOUND(PGP3A,3) IVSETSC(IOFF+1:IOFF+IFGP3A)=KVSETSC3A(:) IOFF=IOFF+IFGP3A ENDDO ENDIF IF(PRESENT(KVSETSC3B)) THEN IFGP3B=UBOUND(KVSETSC3B,1) DO J3=1,UBOUND(PGP3B,3) IVSETSC(IOFF+1:IOFF+IFGP3B)=KVSETSC3B(:) IOFF=IOFF+IFGP3B ENDDO ENDIF ENDIF IST = 1 IF(KF_UV_G > 0) THEN IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G IVSET(IST:IST+KF_UV_G-1) = IVSETUV(:) IST = IST+KF_UV_G ENDIF IF(KF_SCALARS_G > 0) THEN IVSET(IST:IST+KF_SCALARS_G-1) = IVSETSC(:) IST = IST+KF_SCALARS_G ENDIF IF (NSTACK_MEMORY_TR == 1) THEN ZGTF => ZGTF_STACK(:,:) ELSE ALLOCATE(ZGTF_HEAP(KF_FS,D%NLENGTF)) ! Now, force the OS to allocate this shared array right now, not when it starts ! to be used which is an OPEN-MP loop, that would cause a threads ! synchronization lock : IF (KF_FS > 0 .AND. D%NLENGTF > 0) THEN ZGTF_HEAP(1,1)=HUGE(1._JPRB) ENDIF ZGTF => ZGTF_HEAP(:,:) ENDIF ! Transposition CALL GSTATS(158,0) CALL TRGTOL(ZGTF,KF_FS,KF_GP,KF_SCALARS_G,IVSET,KPTRGP,& &PGP,PGPUV,PGP3A,PGP3B,PGP2) CALL GSTATS(158,1) CALL GSTATS(106,0) ! Fourier transform IBLEN=D%NLENGT0B*2*KF_FS IF (ALLOCATED(FOUBUF_IN)) THEN IF (MAX(1,IBLEN) > SIZE(FOUBUF_IN)) THEN DEALLOCATE(FOUBUF_IN) ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) ENDIF ELSE ALLOCATE(FOUBUF_IN(MAX(1,IBLEN))) ENDIF CALL GSTATS(1640, 0) ! If this rank has any Fourier fields, Fourier transform them IF (KF_FS > 0) THEN ! Loop over latitudes !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL) DO JGL = 1, D%NDGL_FS ! Fourier transform CALL FTDIR(ZGTF, KF_FS, JGL) ! Save Fourier data in FOUBUF_IN CALL FOURIER_OUT(ZGTF, KF_FS, JGL) ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1640, 1) CALL GSTATS(106,1) ! ------------------------------------------------------------------ END SUBROUTINE FTDIR_CTL END MODULE FTDIR_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/uvtvdad_mod.F900000664000175000017500000001006415174631767022502 0ustar alastairalastair! (C) Copyright 1991- ECMWF. ! (C) Copyright 1991- 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. ! MODULE UVTVDAD_MOD CONTAINS SUBROUTINE UVTVDAD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) !**** *UVTVDAD* - Compute vor/div from u and v in spectral space ! Purpose. ! -------- ! To compute vorticity and divergence from u and v in spectral ! space. Input u and v from KM to NTMAX+1, output vorticity and ! divergence from KM to NTMAX. !** Interface. ! ---------- ! CALL UVTVDAD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) ! Explicit arguments : KM - zonal wave-number ! -------------------- KFIELD - number of fields (levels) ! PEPSNM - REPSNM for wavenumber KM ! PU - u wind component for zonal ! wavenumber KM ! PV - v wind component for zonal ! wavenumber KM ! PVOR - vorticity for zonal ! wavenumber KM ! PDIV - divergence for zonal ! wavenumber KM ! Method. See ref. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 91-07-01 ! D. Giard : NTMAX instead of NSMAX ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD INTEGER(KIND=JPIM), INTENT(IN) :: KM REAL(KIND=JPRB), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:),PDIV(:,:) REAL(KIND=JPRB), INTENT(INOUT) :: PU (:,:),PV (:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IN, IR, J, JN, ITMAX ! LOCAL REAL SCALARS REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZN(-1:R%NTMAX+3) ! ------------------------------------------------------------------ !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ ZKM = KM ITMAX = R%NTMAX ZN(KM-1:ITMAX+3) = REAL(F%RN(KM-1:ITMAX+3),JPRB) !* 1.2 COMPUTE VORTICITY AND DIVERGENCE. IF(KM /= 0) THEN DO JN=KM,ITMAX IN = ITMAX+2-JN !DIR$ IVDEP !OCL NOVREC DO J=1,KFIELD IR = 2*J-1 II = IR+1 PV(IN,II) = PV(IN,II)-ZKM*PVOR(IN,IR) PU(IN-1,IR) = PU(IN-1,IR)-ZN(JN)*PEPSNM(JN+1)*PVOR(IN,IR) PU(IN+1,IR) = PU(IN+1,IR)+ZN(JN+1)*PEPSNM(JN)*PVOR(IN,IR) PV(IN,IR) = PV(IN,IR)+ZKM*PVOR(IN,II) PU(IN-1,II) = PU(IN-1,II)-ZN(JN)*PEPSNM(JN+1)*PVOR(IN,II) PU(IN+1,II) = PU(IN+1,II)+ZN(JN+1)*PEPSNM(JN)*PVOR(IN,II) PU(IN,II) = PU(IN,II)-ZKM*PDIV(IN,IR) PV(IN-1,IR) = PV(IN-1,IR)+ZN(JN)*PEPSNM(JN+1)*PDIV(IN,IR) PV(IN+1,IR) = PV(IN+1,IR)-ZN(JN+1)*PEPSNM(JN)*PDIV(IN,IR) PU(IN,IR) = PU(IN,IR)+ZKM*PDIV(IN,II) PV(IN-1,II) = PV(IN-1,II)+ZN(JN)*PEPSNM(JN+1)*PDIV(IN,II) PV(IN+1,II) = PV(IN+1,II)-ZN(JN+1)*PEPSNM(JN)*PDIV(IN,II) ENDDO ENDDO ELSE DO JN=KM,ITMAX IN = ITMAX+2-JN DO J=1,KFIELD IR = 2*J-1 PU(IN-1,IR) = PU(IN-1,IR)-ZN(JN )*PEPSNM(JN+1)*PVOR(IN,IR) PU(IN+1,IR) = PU(IN+1,IR)+ZN(JN+1)*PEPSNM(JN )*PVOR(IN,IR) PV(IN-1,IR) = PV(IN-1,IR)+ZN(JN )*PEPSNM(JN+1)*PDIV(IN,IR) PV(IN+1,IR) = PV(IN+1,IR)-ZN(JN+1)*PEPSNM(JN )*PDIV(IN,IR) ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE UVTVDAD END MODULE UVTVDAD_MOD ectrans-1.8.0/src/trans/cpu/internal/spnsde_mod.F900000664000175000017500000000566415174631767022333 0ustar alastairalastair! (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. ! MODULE SPNSDE_MOD CONTAINS SUBROUTINE SPNSDE(KM,KF_SCALARS,PEPSNM,PF,PNSD) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F !**** *SPNSDE* - Compute North-South derivative in spectral space ! Purpose. ! -------- ! In Laplace space compute the the North-south derivative !** Interface. ! ---------- ! CALL SPNSDE(...) ! Explicit arguments : ! -------------------- ! KM -zonal wavenumber (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PF (NLEI1,2*KF_SCALARS) - input field (input) ! PNSD(NLEI1,2*KF_SCALARS) - N-S derivative (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : YOMLAP ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From SPNSDE in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS REAL(KIND=JPRB), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(IN) :: PF(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PNSD(:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IJ, ISKIP, J, JN,JI,ISMAX REAL(KIND=JPRB) :: ZEPSNM(-1:R%NSMAX+4) REAL(KIND=JPRB) :: ZN(-1:R%NTMAX+4) ! ------------------------------------------------------------------ !* 1. COMPUTE NORTH SOUTH DERIVATIVE. ! ------------------------------- !* 1.1 COMPUTE ISMAX = R%NSMAX DO JN=KM-1,ISMAX+2 IJ = ISMAX+3-JN ZN(IJ) = REAL(F%RN(JN),JPRB) IF( JN >= 0 ) ZEPSNM(IJ) = PEPSNM(JN) ENDDO ZN(0) = REAL(F%RN(ISMAX+3),JPRB) IF(KM == 0) THEN ISKIP = 2 ELSE ISKIP = 1 ENDIF DO J=1,2*KF_SCALARS,ISKIP DO JI=2,ISMAX+3-KM PNSD(JI,J) = -ZN(JI+1)*ZEPSNM(JI)*PF(JI+1,J)+& &ZN(JI-2)*ZEPSNM(JI-1)*PF(JI-1,J) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE SPNSDE END MODULE SPNSDE_MOD ectrans-1.8.0/src/trans/cpu/internal/inv_trans_ctlad_mod.F900000664000175000017500000002354715174631767024211 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE INV_TRANS_CTLAD_MOD CONTAINS SUBROUTINE INV_TRANS_CTLAD(KF_UV_G,KF_SCALARS_G,KF_GP,KF_FS,KF_OUT_LT,& & KF_UV,KF_SCALARS,KF_SCDERS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANS_CTLAD* - Control routine for inverse spectral transform adj. ! Purpose. ! -------- ! Control routine for the inverse spectral transform !** Interface. ! ---------- ! CALL INV_TRANS_CTLAD(...) ! Explicit arguments : ! -------------------- ! KF_UV_G - global number of spectral u-v fields ! KF_SCALARS_G - global number of scalar spectral fields ! KF_GP - total number of output gridpoint fields ! KF_FS - total number of fields in fourier space ! KF_OUT_LT - total number of fields coming out from inverse LT ! KF_UV - local number of spectral u-v fields ! KF_SCALARS - local number of scalar spectral fields ! KF_SCDERS - local number of derivatives of scalar spectral fields ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPSCALAR(:,:) - spectral scalarvalued fields (input) ! 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. ! PGP(:,:,:) - gridpoint fields (output) ! The ordering of the output fields is as follows (all ! parts are optional depending on the input switches): ! ! vorticity : KF_UV_G fields ! divergence : KF_UV_G fields ! u : KF_UV_G fields ! v : KF_UV_G fields ! scalar fields : KF_SCALARS_G fields ! N-S derivative of scalar fields : KF_SCALARS_G fields ! E-W derivative of u : KF_UV_G fields ! E-W derivative of v : KF_UV_G fields ! E-W derivative of scalar fields : KF_SCALARS_G fields ! ! Method. ! ------- ! Externals. SHUFFLE - reshuffle fields for load balancing ! ---------- FIELD_SPLIT - split fields in NPROMATR packets ! LTINV_CTLAD - control of Legendre transform ! FTINV_CTLAD - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 01-01-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_GEN ,ONLY : NPROMATR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP !USE TPM_DISTR USE SHUFFLE_MOD ,ONLY : SHUFFLE USE FIELD_SPLIT_MOD ,ONLY : FIELD_SPLIT USE LTINV_CTLAD_MOD ,ONLY : LTINV_CTLAD USE FTINV_CTLAD_MOD ,ONLY : FTINV_CTLAD ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G INTEGER(KIND=JPIM), INTENT(IN) :: KF_GP INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT INTEGER(KIND=JPIM), INTENT(IN) :: KF_UV INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCDERS 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(:,:) 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(:) 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(:,:,:) ! Local variables INTEGER(KIND=JPIM) :: IPTRGP(KF_GP),IPTRSPUV(NPROMATR),IPTRSPSC(NPROMATR) INTEGER(KIND=JPIM) :: ISHFUV_G(KF_GP),ISHFSC_G(KF_GP) INTEGER(KIND=JPIM) :: IVSETUV(KF_GP),IVSETSC(KF_GP) INTEGER(KIND=JPIM) :: IBLKS,JBLK,ISTUV_G,IENUV_G INTEGER(KIND=JPIM) :: IF_UV_G,IF_UV,ISTUV,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: JFLD,ISTSC_G,IENSC_G,ISTSC,IENSC,IENUV,IF_SCDERS,IF_OUT_LT INTEGER(KIND=JPIM) :: IOFFD,IOFFU,IOFFV,IOFFUVD,IOFFSC,IOFFSCNS,IOFFSCEW,IOFF,IF_GPB ! ------------------------------------------------------------------ ! Perform transform IF_GPB = 2*KF_UV_G+KF_SCALARS_G IF(NPROMATR > 0 .AND. IF_GPB > NPROMATR) THEN ! Fields to be split into packets CALL SHUFFLE(KF_UV_G,KF_SCALARS_G,ISHFUV_G,IVSETUV,ISHFSC_G,IVSETSC,& & KVSETUV,KVSETSC) IBLKS=(IF_GPB-1)/NPROMATR+1 DO JBLK=1,IBLKS CALL FIELD_SPLIT(JBLK,IF_GPB,KF_UV_G,IVSETUV,IVSETSC,& & ISTUV_G,IENUV_G,IF_UV_G,ISTSC_G,IENSC_G,IF_SCALARS_G,& & ISTUV,IENUV,IF_UV,ISTSC,IENSC,IF_SCALARS) IF(LSCDERS) THEN IF_SCDERS = IF_SCALARS ELSE IF_SCDERS = 0 ENDIF IF_OUT_LT = 2*IF_UV + IF_SCALARS+IF_SCDERS IF(LVORGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF(LDIVGP) THEN IF_OUT_LT = IF_OUT_LT+IF_UV ENDIF IF_FS = IF_OUT_LT+IF_SCDERS IF(LUVDER) THEN IF_FS = IF_FS+2*IF_UV ENDIF IF_GP = 2*IF_UV_G+IF_SCALARS_G IOFFD = 0 IOFFU = 0 IOFFV = KF_UV_G IOFFUVD = 2*KF_UV_G+KF_SCALARS_G IOFFSC = 2*KF_UV_G IF(LVORGP) THEN IF_GP = IF_GP+IF_UV_G IOFFD = KF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LDIVGP) THEN IF_GP = IF_GP+IF_UV_G IOFFU = IOFFU+KF_UV_G IOFFV = IOFFV+KF_UV_G IOFFUVD =IOFFUVD+KF_UV_G IOFFSC = IOFFSC+KF_UV_G ENDIF IF(LSCDERS) THEN IF_GP = IF_GP+2*IF_SCALARS_G IOFFUVD =IOFFUVD+KF_SCALARS_G IOFFSCNS = IOFFSC+KF_SCALARS_G IOFFSCEW = IOFFSC+2*KF_SCALARS_G ENDIF IF(LUVDER) THEN IF_GP = IF_GP+2*IF_UV_G IOFFSCEW = IOFFSCEW+2*KF_UV_G ENDIF DO JFLD=1,IF_UV_G IOFF = 0 IF(LVORGP) THEN IPTRGP(JFLD+IOFF) = ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IF(LDIVGP) THEN IPTRGP(JFLD+IOFF) = IOFFD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFU+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFV+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G+IF_SCALARS_G IF(LSCDERS) THEN IOFF = IOFF+IF_SCALARS_G ENDIF IF(LUVDER) THEN IPTRGP(JFLD+IOFF) = IOFFUVD+ISHFUV_G(ISTUV_G+JFLD-1) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFUVD+KF_UV_G+ISHFUV_G(ISTUV_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_SCALARS_G IOFF = 2*IF_UV_G IF (LVORGP) IOFF = IOFF+IF_UV_G IF (LDIVGP) IOFF = IOFF+IF_UV_G IPTRGP(JFLD+IOFF) = IOFFSC+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LSCDERS) THEN IPTRGP(JFLD+IOFF) = IOFFSCNS+ISHFSC_G(ISTSC_G+JFLD-1) IOFF = IOFF+IF_SCALARS_G IF(LUVDER) THEN IOFF = IOFF+2*IF_UV_G ENDIF IPTRGP(JFLD+IOFF) = IOFFSCEW+ISHFSC_G(ISTSC_G+JFLD-1) ENDIF ENDDO DO JFLD=1,IF_UV IPTRSPUV(JFLD) = ISTUV+JFLD-1 ENDDO DO JFLD=1,IF_SCALARS IPTRSPSC(JFLD) = ISTSC+JFLD-1 ENDDO IF(IF_UV_G > 0 .AND. IF_SCALARS_G > 0) THEN CALL FTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_UV_G > 0) THEN CALL FTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETUV=IVSETUV(ISTUV_G:IENUV_G),& & KPTRGP=IPTRGP,& & PGP=PGP) ELSEIF(IF_SCALARS_G > 0) THEN CALL FTINV_CTLAD(IF_UV_G,IF_SCALARS_G,& & IF_UV,IF_SCALARS,IF_SCDERS,IF_GP,IF_FS,IF_OUT_LT,& & KVSETSC=IVSETSC(ISTSC_G:IENSC_G),KPTRGP=IPTRGP,& & PGP=PGP) ENDIF CALL LTINV_CTLAD(IF_OUT_LT,IF_UV,IF_SCALARS,IF_SCDERS, & & PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& & KFLDPTRUV=IPTRSPUV,KFLDPTRSC=IPTRSPSC) ENDDO ELSE ! No splitting of fields, transform done in one go CALL FTINV_CTLAD(KF_UV_G,KF_SCALARS_G,& & KF_UV,KF_SCALARS,KF_SCDERS,KF_GP,KF_FS,KF_OUT_LT,& & KVSETUV=KVSETUV,KVSETSC=KVSETSC,& & KVSETSC3A=KVSETSC3A,KVSETSC3B=KVSETSC3B,KVSETSC2=KVSETSC2,& & PGP=PGP,PGPUV=PGPUV,PGP3A=PGP3A,PGP3B=PGP3B,PGP2=PGP2) CALL LTINV_CTLAD(KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS, & &PSPVOR=PSPVOR,PSPDIV=PSPDIV,PSPSCALAR=PSPSCALAR,& &PSPSC3A=PSPSC3A,PSPSC3B=PSPSC3B,PSPSC2=PSPSC2) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE INV_TRANS_CTLAD END MODULE INV_TRANS_CTLAD_MOD ectrans-1.8.0/src/trans/cpu/internal/updsp_mod.F900000664000175000017500000001120115174631767022152 0ustar alastairalastair! (C) Copyright 1988- ECMWF. ! (C) Copyright 1988- 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. ! MODULE UPDSP_MOD CONTAINS SUBROUTINE UPDSP(KM,KF_UV,KF_SCALARS,POA1,POA2, & & PSPVOR,PSPDIV,PSPSCALAR,& & PSPSC3A,PSPSC3B,PSPSC2 , & & KFLDPTRUV,KFLDPTRSC) !**** *UPDSP* - Update spectral arrays after direct Legendre transform ! Purpose. ! -------- ! To update the spectral arrays for a fixed zonal wave-number ! from values in POA1 and POA2. !** Interface. ! ---------- ! CALL UPDSP(...) ! Explicit arguments : ! -------------------- ! KM - zonal wave-number ! POA1 - spectral fields for zonal wavenumber KM (basic var.) ! POA2 - spectral fields for zonal wavenumber KM (vor. div.) ! PSPVOR - spectral vorticity ! PSPDIV - spectral divergence ! PSPSCALAR - spectral scalar variables ! Implicit arguments : ! -------------------- ! Method. ! ------- ! Externals. UPDSPB - basic transfer routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 88-02-02 ! Modified : 91-07-01 Philippe Courtier/Mats Hamrud - Rewrite ! for uv formulation ! Modified : 94-08-02 R. El Khatib - interface to UPDSPB ! M.Hamrud : 94-11-01 New conf 'G' - vor,div->vor,div ! instead of u,v->vor,div ! MPP Group: 95-10-01 Support for Distributed Memory version ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B USE TPM_DISTR ,ONLY : D USE UPDSPB_MOD ,ONLY : UPDSPB ! IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM), INTENT(IN) :: KM,KF_UV,KF_SCALARS REAL(KIND=JPRB) , INTENT(IN) :: POA1(:,:) REAL(KIND=JPRB) , INTENT(IN) :: POA2(:,:) 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) :: PSPSC2(:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL,INTENT(OUT) :: PSPSC3B(:,:,:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRUV(:) INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KFLDPTRSC(:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IVORS, IVORE, IDIVS, IDIVE, IST ,IEND,JFLD,IFLD,IDIM1,IDIM3,J3 ! ------------------------------------------------------------------ !* 1. UPDATE FIELDS ! ------------- !* 1.1 VORTICITY AND DIVERGENCE. IST = 1 IF (KF_UV > 0) THEN IST = IST+4*KF_UV IVORS = 1 IVORE = 2*KF_UV IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV CALL UPDSPB(KM,KF_UV,POA2(:,IVORS:IVORE),PSPVOR,KFLDPTRUV) CALL UPDSPB(KM,KF_UV,POA2(:,IDIVS:IDIVE),PSPDIV,KFLDPTRUV) IF (KM == 0) THEN IF(PRESENT(KFLDPTRUV)) THEN DO JFLD=1,KF_UV IFLD = KFLDPTRUV(JFLD) PSPVOR(IFLD,D%NASM0(0)) = 0.0_JPRB PSPDIV(IFLD,D%NASM0(0)) = 0.0_JPRB ENDDO ELSE DO JFLD=1,KF_UV PSPVOR(JFLD,D%NASM0(0)) = 0.0_JPRB PSPDIV(JFLD,D%NASM0(0)) = 0.0_JPRB ENDDO ENDIF ENDIF ENDIF !* 1.2 SCALARS IF (KF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IEND = IST+2*KF_SCALARS-1 CALL UPDSPB(KM,KF_SCALARS,POA1(:,IST:IEND),PSPSCALAR,KFLDPTRSC) ELSE IF(PRESENT(PSPSC2) .AND. NF_SC2 > 0) THEN IDIM1 = NF_SC2 IEND = IST+2*IDIM1-1 CALL UPDSPB(KM,IDIM1,POA1(:,IST:IEND),PSPSC2) IST=IST+2*IDIM1 ENDIF IF(PRESENT(PSPSC3A) .AND. NF_SC3A > 0) THEN IDIM1=NF_SC3A IDIM3=UBOUND(PSPSC3A,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPB(KM,IDIM1,POA1(:,IST:IEND),PSPSC3A(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF IF(PRESENT(PSPSC3B) .AND. NF_SC3B > 0) THEN IDIM1=NF_SC3B IDIM3=UBOUND(PSPSC3B,3) DO J3=1,IDIM3 IEND = IST+2*IDIM1-1 CALL UPDSPB(KM,IDIM1,POA1(:,IST:IEND),PSPSC3B(:,:,J3)) IST=IST+2*IDIM1 ENDDO ENDIF ENDIF ENDIF ! ------------------------------------------------------------------ END SUBROUTINE UPDSP END MODULE UPDSP_MOD ectrans-1.8.0/src/trans/cpu/internal/asre1bad_mod.F900000664000175000017500000000614215174631767022511 0ustar alastairalastair! (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. ! MODULE ASRE1BAD_MOD CONTAINS SUBROUTINE ASRE1BAD(KFIELD,KM,KMLOC,PAOA,PSOA) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : FOUBUF_IN USE TPM_GEOMETRY ,ONLY : G USE TPM_DISTR ,ONLY : D !**** *ASRE1BAD* - Recombine antisymmetric and symmetric parts - adjoint ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *ASRE1BAD(..) ! Explicit arguments : ! ------------------- KFIELD - number of fields (input-c) ! KM - zonal wavenumber(input-c) ! KMLOC - local version of KM (input-c) ! PAOA - antisymmetric part of Fourier ! fields for zonal wavenumber KM (input) ! PSOA - symmetric part of Fourier ! fields for zonal wavenumber KM (input) ! Implicit arguments : FOUBUF_IN - output buffer (output) ! -------------------- ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1BAD in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KFIELD,KM,KMLOC REAL(KIND=JPRB), INTENT(OUT) :: PSOA(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PAOA(:,:) ! LOCAL INTEGERS INTEGER(KIND=JPIM) :: ISL, IGLS, JFLD, JGL ,IPROC, IPROCS, IDGNH INTEGER(KIND=JPIM) :: ISTAN(R%NDGNH),ISTAS(R%NDGNH) ! ------------------------------------------------------------------ !* 1. RECOMBINATION OF SYMMETRIC AND ANTSYMMETRIC PARTS. ! --------------------------------------------------- ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IDGNH = R%NDGNH !* 1.2 RECOMBINE DO JGL=ISL,IDGNH IPROC = D%NPROCL(JGL) ISTAN(JGL) = (D%NSTAGT0B(IPROC) + D%NPNTGTB1(KMLOC,JGL))*2*KFIELD IGLS = R%NDGL+1-JGL IPROCS = D%NPROCL(IGLS) ISTAS(JGL) = (D%NSTAGT0B(IPROCS) + D%NPNTGTB1(KMLOC,IGLS))*2*KFIELD ENDDO DO JGL=ISL,IDGNH !OCL NOVREC DO JFLD=1,2*KFIELD PSOA(JFLD,JGL) = FOUBUF_IN(ISTAN(JGL)+JFLD)+FOUBUF_IN(ISTAS(JGL)+JFLD) PAOA(JFLD,JGL) = FOUBUF_IN(ISTAN(JGL)+JFLD)-FOUBUF_IN(ISTAS(JGL)+JFLD) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE ASRE1BAD END MODULE ASRE1BAD_MOD ectrans-1.8.0/src/trans/cpu/internal/set_resol_mod.F900000664000175000017500000000407215174631767023026 0ustar alastairalastair! (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. ! MODULE SET_RESOL_MOD CONTAINS SUBROUTINE SET_RESOL(KRESOL,LDSETUP) USE PARKIND1 ,ONLY : JPIM USE TPM_GEN ,ONLY : NOUT, MSETUP0, NCUR_RESOL, NMAX_RESOL,LENABLED USE TPM_DIM ,ONLY : R, DIM_RESOL USE TPM_DISTR ,ONLY : D, DISTR_RESOL USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL USE TPM_FFTW ,ONLY : TW, FFTW_RESOL USE TPM_FLT ,ONLY : S, FLT_RESOL USE TPM_CTL ,ONLY : C, CTL_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS ! IMPLICIT NONE ! Declaration of arguments INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL LOGICAL ,OPTIONAL, INTENT(IN) :: LDSETUP ! Local variables INTEGER(KIND=JPIM) :: IRESOL LOGICAL :: LLSETUP ! ------------------------------------------------------------------ IF(MSETUP0 == 0) CALL ABORT_TRANS('SET_RESOL:TRANS NOT SETUP') LLSETUP = .FALSE. IF(PRESENT(LDSETUP)) LLSETUP = LDSETUP IRESOL = 1 IF(PRESENT(KRESOL)) THEN IRESOL = KRESOL IF(IRESOL < 1 .OR. IRESOL > NMAX_RESOL) THEN WRITE(NOUT,*)'SET_RESOL: UNKNOWN RESOLUTION ',IRESOL,NMAX_RESOL CALL ABORT_TRANS('SET_RESOL:IRESOL < 1 .OR. KRESOL > NMAX_RESOL') ENDIF IF(.NOT.LLSETUP) THEN IF(.NOT.LENABLED(IRESOL)) THEN WRITE(NOUT,*)'SET_RESOL: UNKNOWN RESOLUTION ',IRESOL,LENABLED CALL ABORT_TRANS('SET_RESOL:IRESOL NOT ENABLED') ENDIF ENDIF ENDIF IF(IRESOL /= NCUR_RESOL) THEN NCUR_RESOL = IRESOL R => DIM_RESOL(NCUR_RESOL) F => FIELDS_RESOL(NCUR_RESOL) G => GEOM_RESOL(NCUR_RESOL) D => DISTR_RESOL(NCUR_RESOL) TW => FFTW_RESOL(NCUR_RESOL) S => FLT_RESOL(NCUR_RESOL) C => CTL_RESOL(NCUR_RESOL) ENDIF END SUBROUTINE SET_RESOL END MODULE SET_RESOL_MOD ectrans-1.8.0/src/trans/cpu/internal/dist_grid_32_ctl_mod.F900000664000175000017500000001625615174631767024154 0ustar alastairalastair! (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. ! MODULE DIST_GRID_32_CTL_MOD CONTAINS SUBROUTINE DIST_GRID_32_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP) !**** *DIST_GRID_32_CTL* - Distributing global gridpoint array to processors ! Purpose. ! -------- ! Routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID_32_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint output ! KFROM(:) - Processor responsible for distributing each field ! PGP(:,:,:) - Local spectral array ! Externals. SET2PE - compute "A and B" set from PE ! ---------- MPL.. - message passing routines ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRM USE MPL_MODULE USE TPM_DISTR ,ONLY : D, NPROC, MYPROC, NPRCIDS, MTAGDISTGP USE TPM_GEOMETRY, ONLY : G USE SET2PE_MOD, ONLY : SET2PE USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE EQ_REGIONS_MOD, ONLY : N_REGIONS, N_REGIONS_NS IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) REAL(KIND=JPRM) , INTENT(OUT) :: PGP(:,:,:) ! Declaration of local variables REAL(KIND=JPRM),ALLOCATABLE :: ZBUF(:,:,:),ZRCV2(:,:) REAL(KIND=JPRM) :: ZRCV(D%NGPTOTMX,KFDISTG) INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF,ILENR INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG) INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD,IFLDSFROM(NPROC) LOGICAL :: LLSAME ! ------------------------------------------------------------------ ! Copy for single PE IF(NPROC == 1) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,JFLD,IBL) = PGPG(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ELSEIF(KFDISTG>0) THEN ! test if values in KFROM are all the same LLSAME=.TRUE. IFROM=KFROM(1) DO JFLD=2,KFDISTG IF(KFROM(JFLD) /= IFROM) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO IMYFIELDS = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO CALL GSTATS(1663,0) IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILOFF,JGL,JLON) DO JFLD=1,IMYFIELDS DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(ISND,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN(ISND,JFLD) = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = & & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) ENDDO ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1663,1) ! Message passing CALL GSTATS_BARRIER(791) CALL GSTATS(811,0) ! Send IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN ITAG = MTAGDISTGP DO JROC=1,NPROC CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),& &CDSTRING='DIST_GRID_32_CTL') ENDDO ENDIF ELSE IF(IMYFIELDS > 0) THEN ITAG = MTAGDISTGP DO JROC=1,NPROC CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),& &CDSTRING='DIST_GRID_32_CTL') ENDDO ENDIF ENDIF ! Receive IF( LLSAME )THEN IRCV = KFROM(1) ITAG = MTAGDISTGP CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_32_CTL:') IF( ILENR /= D%NGPTOTMX*KFDISTG )THEN CALL ABORT_TRANS(' DIST_GRID_32_CTL: INVALID RECEIVE MESSAGE LENGTH 1') ENDIF ELSE IFLDSFROM(:)=0 DO JFLD=1,KFDISTG IFLDSFROM(KFROM(JFLD)) = IFLDSFROM(KFROM(JFLD))+1 ENDDO ITAG = MTAGDISTGP DO JROC=1,NPROC IF(IFLDSFROM(JROC) > 0 ) THEN IRCV = JROC ALLOCATE(ZRCV2(D%NGPTOTMX,IFLDSFROM(JROC))) CALL MPL_RECV(ZRCV2,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_32_CTL:') IF( ILENR /= D%NGPTOTMX*IFLDSFROM(JROC) )THEN CALL ABORT_TRANS(' DIST_GRID_32_CTL: INVALID RECEIVE MESSAGE LENGTH 2') ENDIF IFLD = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == JROC) THEN IFLD = IFLD+1 ZRCV(1:D%NGPTOT,JFLD) = ZRCV2(1:D%NGPTOT,IFLD) ENDIF ENDDO DEALLOCATE(ZRCV2) ENDIF ENDDO ENDIF ! Wait for send to complete IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), & & CDSTRING='DIST_GRID_32_CTL: WAIT 1') ENDIF ELSEIF(IMYFIELDS > 0) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), & & CDSTRING='DIST_GRID_32_CTL: WAIT 2') ENDIF CALL GSTATS(811,1) CALL GSTATS_BARRIER2(791) CALL GSTATS(1663,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,JFLD,IBL) = ZRCV(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1663,1) !Synchronize processors CALL GSTATS(786,0) CALL MPL_BARRIER(CDSTRING='DIST_GRID_32_CTL:') CALL GSTATS(786,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID_32_CTL END MODULE DIST_GRID_32_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/vdtuv_mod.F900000664000175000017500000001057315174631767022202 0ustar alastairalastair! (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. ! MODULE VDTUV_MOD CONTAINS SUBROUTINE VDTUV(KM,KFIELD,PEPSNM,PVOR,PDIV,PU,PV) USE PARKIND1 ,ONLY : JPIM ,JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F !**** *VDTUV* - Compute U,V in spectral space ! Purpose. ! -------- ! In Laplace space compute the the winds ! from vorticity and divergence. !** Interface. ! ---------- ! CALL VDTUV(...) ! Explicit arguments : KM -zonal wavenumber (input-c) ! -------------------- KFIELD - number of fields (input-c) ! PEPSNM - REPSNM for wavenumber KM (input-c) ! PVOR(NLEI1,2*KFIELD) - vorticity (input) ! PDIV(NLEI1,2*KFIELD) - divergence (input) ! PU(NLEI1,2*KFIELD) - u wind (output) ! PV(NLEI1,2*KFIELD) - v wind (output) ! Organisation within NLEI1: ! NLEI1 = NSMAX+4+mod(NSMAX+4+1,2) ! overdimensioning ! 1 : n=NSMAX+2 ! 2 : n=NSMAX+1 ! 3 : n=NSMAX ! . : ! . : ! NSMAX+3 : n=0 ! NSMAX+4 : n=-1 ! Implicit arguments : Eigenvalues of inverse Laplace operator ! -------------------- from YOMLAP ! Method. ! ------- ! Externals. None. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Temperton, 1991, MWR 119 p1303 ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From VDTUV in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM,KFIELD REAL(KIND=JPRB), INTENT(IN) :: PEPSNM(0:R%NTMAX+2) REAL(KIND=JPRB), INTENT(IN) :: PVOR(:,:),PDIV(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PU (:,:),PV (:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: II, IJ, IR, J, JN, ISMAX,JI ! LOCAL REAL SCALARS REAL(KIND=JPRB) :: ZKM REAL(KIND=JPRB) :: ZN(-1:R%NTMAX+4) REAL(KIND=JPRB) :: ZLAPIN(-1:R%NSMAX+4) REAL(KIND=JPRB) :: ZEPSNM(-1:R%NSMAX+4) ! ------------------------------------------------------------------ !* 1. COMPUTE U V FROM VORTICITY AND DIVERGENCE. ! ------------------------------------------ ZKM = KM ISMAX = R%NSMAX DO JN=KM-1,ISMAX+2 IJ = ISMAX+3-JN ZN(IJ) = REAL(F%RN(JN),JPRB) ZLAPIN(IJ) = REAL(F%RLAPIN(JN),JPRB) IF( JN >= 0 ) ZEPSNM(IJ) = PEPSNM(JN) ENDDO ZN(0) = REAL(F%RN(ISMAX+3),JPRB) !* 1.1 U AND V (KM=0) . IF(KM == 0) THEN DO J=1,KFIELD IR = 2*J-1 II = IR+1 DO JI=2,ISMAX+3-KM PU(JI,IR) = +& &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PVOR(JI+1,IR)-& &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PVOR(JI-1,IR) PV(JI,IR) = -& &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PDIV(JI+1,IR)+& &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PDIV(JI-1,IR) ! Imaginary components are always zero for KM = 0 PU(JI,II) = 0.0_JPRB PV(JI,II) = 0.0_JPRB ENDDO ENDDO !* 1.2 U AND V (KM!=0) . ELSE DO J=1,KFIELD IR = 2*J-1 II = IR+1 DO JI=2,ISMAX+3-KM PU(JI,IR) = -ZKM*ZLAPIN(JI)*PDIV(JI,II)+& &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PVOR(JI+1,IR)-& &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PVOR(JI-1,IR) PU(JI,II) = +ZKM*ZLAPIN(JI)*PDIV(JI,IR)+& &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PVOR(JI+1,II)-& &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PVOR(JI-1,II) PV(JI,IR) = -ZKM*ZLAPIN(JI)*PVOR(JI,II)-& &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PDIV(JI+1,IR)+& &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PDIV(JI-1,IR) PV(JI,II) = +ZKM*ZLAPIN(JI)*PVOR(JI,IR)-& &ZN(JI+1)*ZEPSNM(JI)*ZLAPIN(JI+1)*PDIV(JI+1,II)+& &ZN(JI-2)*ZEPSNM(JI-1)*ZLAPIN(JI-1)*PDIV(JI-1,II) ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE VDTUV END MODULE VDTUV_MOD ectrans-1.8.0/src/trans/cpu/internal/asre1_mod.F900000664000175000017500000000471415174631767022045 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! MODULE ASRE1_MOD CONTAINS SUBROUTINE ASRE1(KM,KMLOC,KF_OUT_LT,PAOA1,PSOA1) USE PARKIND1 ,ONLY : JPIM ,JPRB USE ASRE1B_MOD ,ONLY : ASRE1B !**** *ASRE1* - Recombine antisymmetric and symmetric parts ! Purpose. ! -------- ! To recombine the antisymmetric and symmetric parts of the ! Fourier arrays and update the correct parts of the state ! variables. !** Interface. ! ---------- ! *CALL* *ASRE1(...) ! Explicit arguments : ! -------------------- ! KM - zonal wavenumber ! KMLOC - local zonal wavenumber ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (basic ! variables and N-S derivatives) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (basic ! variables and N-S derivatives) ! Implicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. ASRE1B - basic recombination routine ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Mats Hamrud and Philippe Courtier *ECMWF* ! Modifications. ! -------------- ! Original : 00-02-01 From ASRE1 in IFS CY22R1 ! ------------------------------------------------------------------ IMPLICIT NONE ! DUMMY INTEGER SCALARS INTEGER(KIND=JPIM) , INTENT(IN) :: KM INTEGER(KIND=JPIM) , INTENT(IN) :: KMLOC INTEGER(KIND=JPIM) , INTENT(IN) :: KF_OUT_LT REAL(KIND=JPRB) , INTENT(IN) :: PSOA1(:,:), PAOA1(:,:) ! LOCAL INTEGER SCALARS INTEGER(KIND=JPIM) :: IFLDS ! ------------------------------------------------------------------ IFLDS = KF_OUT_LT CALL ASRE1B(IFLDS,KM,KMLOC,PAOA1,PSOA1) ! ------------------------------------------------------------------ END SUBROUTINE ASRE1 END MODULE ASRE1_MOD ectrans-1.8.0/src/trans/cpu/internal/ledir_mod.F900000664000175000017500000001766715174631767022144 0ustar alastairalastair! (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. ! MODULE LEDIR_MOD CONTAINS SUBROUTINE LEDIR(KM,KMLOC,KFC,KIFC,KSL,KDGLU,KLED2,PAIA,PSIA,POA1,PW) !**** *LEDIR* - Direct Legendre transform. ! Purpose. ! -------- ! Direct Legendre tranform of state variables. !** Interface. ! ---------- ! CALL LEDIR(...) ! Explicit arguments : KM - zonal wavenumber ! -------------------- KFC - number of field to transform ! PAIA - antisymmetric part of Fourier ! fields for zonal wavenumber KM ! PSIA - symmetric part of Fourier ! fields for zonal wavenumber KM ! POA1 - spectral ! fields for zonal wavenumber KM ! Implicit arguments : None. ! -------------------- ! Method. ! ------- use butterfly or dgemm ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Nils Wedi + Mats Hamrud + George Modzynski ! Modifications. ! -------------- ! J.Hague : Oct 2012 DR_HOOK round calls to DGEMM: ! F. Vana 05-Mar-2015 Support for single precision ! P. Dueben : Dec 2019 Improvements for mass conservation in single precision ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPRD, JPRM, JPIM, JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_FLT ,ONLY : S USE BUTTERFLY_ALG_MOD, ONLY : MULT_BUTM USE ECTRANS_BLAS_MOD, ONLY : GEMM IMPLICIT NONE ! DUMMY ARGUMENTS INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KIFC INTEGER(KIND=JPIM), INTENT(IN) :: KSL INTEGER(KIND=JPIM), INTENT(IN) :: KDGLU INTEGER(KIND=JPIM), INTENT(IN) :: KLED2 REAL(KIND=JPRD), INTENT(IN) :: PW(KDGLU+KSL-1) REAL(KIND=JPRB), INTENT(IN) :: PSIA(:,:), PAIA(:,:) REAL(KIND=JPRB), INTENT(OUT) :: POA1(:,:) ! LOCAL VARIABLES INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, IFLD, J, JK INTEGER(KIND=JPIM) :: ITHRESHOLD REAL(KIND=JPRB) :: ZB(KDGLU,KIFC), ZCA((R%NTMAX-KM+2)/2,KIFC), ZCS((R%NTMAX-KM+3)/2,KIFC) LOGICAL, PARAMETER :: LLDOUBLE = (JPRB == JPRD) CHARACTER(LEN=1) :: CLX REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- !* 1.1 PREPARATIONS. CLX = 'S' IF (LLDOUBLE) CLX = 'D' IA = 1+MOD(R%NTMAX-KM+2,2) IS = 1+MOD(R%NTMAX-KM+1,2) ILA = (R%NTMAX-KM+2)/2 ILS = (R%NTMAX-KM+3)/2 ISL = KSL IF(KM == 0)THEN ISKIP = 2 ELSE ISKIP = 1 ENDIF IF (KIFC > 0 .AND. KDGLU > 0 ) THEN ITHRESHOLD=S%ITHRESHOLD !* 1. ANTISYMMETRIC PART. IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,KDGLU ZB(J,IFLD)=PAIA(JK,ISL+J-1)*PW(ISL+J-1) ENDDO ENDDO IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) IF (LLDOUBLE) THEN CALL GEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRD,S%FA(KMLOC)%RPNMA,KDGLU,& &ZB,KDGLU,0._JPRD,ZCA,ILA) ELSE IF(KM>=1)THEN ! DGEM for the mean to improve mass conservation CALL GEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRM,S%FA(KMLOC)%RPNMA,KDGLU,& &ZB,KDGLU,0._JPRM,ZCA,ILA) ELSE BLOCK REAL(KIND=JPRD), allocatable :: ZB_D(:,:), ZCA_D(:,:), ZRPNMA(:,:) INTEGER(KIND=JPIM) :: I1, I2, I3, I4 I1 = size(S%FA(KMLOC)%RPNMA(:,1)) I2 = size(S%FA(KMLOC)%RPNMA(1,:)) ALLOCATE(ZRPNMA(I1,I2)) ALLOCATE(ZB_D(KDGLU,KIFC)) ALLOCATE(ZCA_D((R%NTMAX-KM+2)/2,KIFC)) IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,KDGLU ZB_D(J,IFLD)=ZB(J,IFLD) ENDDO ENDDO DO I3=1,I1 DO I4=1,I2 ZRPNMA(I3,I4) = S%FA(KMLOC)%RPNMA(I3,I4) END DO END DO CALL GEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRD,ZRPNMA,KDGLU,& &ZB_D,KDGLU,0._JPRD,ZCA_D,ILA) IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILA ZCA(J,IFLD) = ZCA_D(J,IFLD) ENDDO ENDDO DEALLOCATE(ZRPNMA) DEALLOCATE(ZB_D) DEALLOCATE(ZCA_D) END BLOCK END IF ENDIF IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) ELSE IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'BUTM_1',0,ZHOOK_HANDLE) CALL MULT_BUTM('T',S%FA(KMLOC)%YBUT_STRUCT_A,KIFC,ZB,ZCA,KM) IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'BUTM_1',1,ZHOOK_HANDLE) ENDIF IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILA POA1(IA+(J-1)*2,JK) = ZCA(J,IFLD) ENDDO ENDDO !* 1.3 SYMMETRIC PART. IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,KDGLU ZB(J,IFLD)=PSIA(JK,ISL+J-1)*REAL(PW(ISL+J-1),JPRB) ENDDO ENDDO IF(ILS <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) IF (LLDOUBLE) THEN CALL GEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRD,S%FA(KMLOC)%RPNMS,KDGLU,& &ZB,KDGLU,0._JPRD,ZCS,ILS) ELSE IF(KM>=1)THEN ! DGEM for the mean to improve mass conservation CALL GEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRM,S%FA(KMLOC)%RPNMS,KDGLU,& &ZB,KDGLU,0._JPRM,ZCS,ILS) ELSE BLOCK REAL(KIND=JPRD), allocatable :: ZB_D(:,:), ZCS_D(:,:), ZRPNMS(:,:) INTEGER(KIND=JPIM) :: I1, I2, I3, I4 I1 = size(S%FA(KMLOC)%RPNMS(:,1)) I2 = size(S%FA(KMLOC)%RPNMS(1,:)) ALLOCATE(ZRPNMS(I1,I2)) ALLOCATE(ZB_D(KDGLU,KIFC)) ALLOCATE(ZCS_D((R%NTMAX-KM+3)/2,KIFC)) IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,KDGLU ZB_D(J,IFLD)=PSIA(JK,ISL+J-1)*REAL(PW(ISL+J-1),JPRB) ENDDO ENDDO DO I3=1,I1 DO I4=1,I2 ZRPNMS(I3,I4) = S%FA(KMLOC)%RPNMS(I3,I4) END DO END DO CALL GEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRD,ZRPNMS,KDGLU,& &ZB_D,KDGLU,0._JPRD,ZCS_D,ILS) IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILS ZCS(J,IFLD) = ZCS_D(J,IFLD) ENDDO ENDDO DEALLOCATE(ZRPNMS) DEALLOCATE(ZB_D) DEALLOCATE(ZCS_D) END BLOCK END IF ENDIF IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) ELSE IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'BUTM_2',0,ZHOOK_HANDLE) CALL MULT_BUTM('T',S%FA(KMLOC)%YBUT_STRUCT_S,KIFC,ZB,ZCS,KM) IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'BUTM_2',1,ZHOOK_HANDLE) ENDIF IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILS POA1(IS+(J-1)*2,JK) = ZCS(J,IFLD) ENDDO ENDDO ELSE ! This zonal wavenumber KM has no computation to be done (G%NDGLU(KM) = 0) ! This is usually because the wavenumber cannot be represented on the given grid, so we should ! zero POA1 POA1(:,:) = 0.0_JPRB ENDIF ! ------------------------------------------------------------------ END SUBROUTINE LEDIR END MODULE LEDIR_MOD ectrans-1.8.0/src/trans/cpu/internal/leinv_mod.F900000664000175000017500000001201315174631767022136 0ustar alastairalastair! (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. ! MODULE LEINV_MOD CONTAINS SUBROUTINE LEINV(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KSL,KDGLU,PIA,PAOA1,PSOA1) !**** *LEINV* - Inverse Legendre transform. ! Purpose. ! -------- ! Inverse Legendre tranform of all variables(kernel). !** Interface. ! ---------- ! CALL LEINV(...) ! Explicit arguments : KM - zonal wavenumber (input-c) ! -------------------- KFC - number of fields to tranform (input-c) ! PIA - spectral fields ! for zonal wavenumber KM (input) ! PAOA1 - antisymmetric part of Fourier ! fields for zonal wavenumber KM (output) ! PSOA1 - symmetric part of Fourier ! fields for zonal wavenumber KM (output) ! Implicit arguments : None. ! -------------------- ! Method. use butterfly or dgemm ! ------- ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! Nils Wedi + Mats Hamrud + George Modzynski ! ! Modifications. ! -------------- ! J.Hague : Oct 2012 DR_HOOK round calls to GEMM: ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPRD, JPRM, JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R USE TPM_FLT ,ONLY : S USE BUTTERFLY_ALG_MOD, ONLY : MULT_BUTM USE ECTRANS_BLAS_MOD, ONLY : GEMM IMPLICIT NONE INTEGER(KIND=JPIM), INTENT(IN) :: KM INTEGER(KIND=JPIM), INTENT(IN) :: KMLOC INTEGER(KIND=JPIM), INTENT(IN) :: KFC INTEGER(KIND=JPIM), INTENT(IN) :: KIFC INTEGER(KIND=JPIM), INTENT(IN) :: KDGLU INTEGER(KIND=JPIM), INTENT(IN) :: KSL INTEGER(KIND=JPIM), INTENT(IN) :: KF_OUT_LT REAL(KIND=JPRB), INTENT(IN) :: PIA(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PSOA1(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PAOA1(:,:) ! LOCAL INTEGER(KIND=JPIM) :: IA, ILA, ILS, IS, ISKIP, ISL, J1, IFLD, JGL,JK, J,JI, IEND INTEGER(KIND=JPIM) :: ITHRESHOLD REAL(KIND=JPRB) :: ZBA((R%NSMAX-KM+2)/2,KIFC), ZBS((R%NSMAX-KM+3)/2,KIFC), ZC(KDGLU,KIFC) CHARACTER(LEN=1) :: CLX REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ !* 1. PERFORM LEGENDRE TRANFORM. ! -------------------------- !* 1.1 PREPARATIONS. CLX = 'S' IF (JPRB == JPRD) CLX = 'D' !ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) ISL = KSL IEND = KSL + KDGLU - 1 IA = 1+MOD(R%NSMAX-KM+2,2) IS = 1+MOD(R%NSMAX-KM+1,2) ILA = (R%NSMAX-KM+2)/2 ILS = (R%NSMAX-KM+3)/2 IF(KM == 0)THEN ISKIP = 2 DO J1=2,KFC,2 DO JGL=ISL,IEND PSOA1(J1,JGL) = 0.0_JPRB PAOA1(J1,JGL) = 0.0_JPRB ENDDO ENDDO ELSE ISKIP = 1 ENDIF IF( KDGLU > 0 ) THEN ITHRESHOLD=S%ITHRESHOLD ! 1. +++++++++++++ anti-symmetric IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILA ZBA(J,IFLD)=PIA(IA+1+(J-1)*2,JK) ENDDO ENDDO IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) CALL GEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,ZBA,ILA,0._JPRB,ZC,KDGLU) IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) ELSE IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'BUTM_1',0,ZHOOK_HANDLE) CALL MULT_BUTM('N',S%FA(KMLOC)%YBUT_STRUCT_A,KIFC,ZBA,ZC) IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'BUTM_1',1,ZHOOK_HANDLE) ENDIF ! we need the transpose of C IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO JI=1,KDGLU PAOA1(JK,ISL+JI-1) = ZC(JI,IFLD) ENDDO ENDDO ! 2. +++++++++++++ symmetric IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO J=1,ILS ZBS(J,IFLD)=PIA(IS+1+(J-1)*2,JK) ENDDO ENDDO IF(ILS <= ITHRESHOLD .OR. .NOT.S%LUSEFLT ) THEN IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) CALL GEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,ZBS,ILS,0._JPRB,ZC,KDGLU) IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) ELSE IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'BUTM_2',0,ZHOOK_HANDLE) CALL MULT_BUTM('N',S%FA(KMLOC)%YBUT_STRUCT_S,KIFC,ZBS,ZC) IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'BUTM_2',1,ZHOOK_HANDLE) ENDIF ! we need the transpose of C IFLD=0 DO JK=1,KFC,ISKIP IFLD=IFLD+1 DO JI=1,KDGLU PSOA1(JK,ISL+JI-1) = ZC(JI,IFLD) ENDDO ENDDO ENDIF ! ------------------------------------------------------------------ END SUBROUTINE LEINV END MODULE LEINV_MOD ectrans-1.8.0/src/trans/cpu/internal/dist_grid_ctl_mod.F900000664000175000017500000001701015174631767023635 0ustar alastairalastair! (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. ! MODULE DIST_GRID_CTL_MOD CONTAINS SUBROUTINE DIST_GRID_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP,KSORT) !**** *DIST_GRID_CTL* - Distributing global gridpoint array to processors ! Purpose. ! -------- ! Routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID_CTL(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint output ! KFROM(:) - Processor responsible for distributing each field ! PGP(:,:,:) - Local spectral array ! KSORT(:) - Add KSORT ! Externals. SET2PE - compute "A and B" set from PE ! ---------- MPL.. - message passing routines ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! P.Marguinaud : 2014-10-10 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : D, MTAGDISTGP, NPRCIDS, MYPROC, NPROC USE TPM_GEOMETRY ,ONLY : G USE SET2PE_MOD ,ONLY : SET2PE USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE EQ_REGIONS_MOD ,ONLY : N_REGIONS, N_REGIONS_NS ! IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN), TARGET :: KSORT (:) ! Declaration of local variables ! SS/2018: Removed stack hogs !REAL(KIND=JPRB) :: ZDUM(D%NGPTOTMX) -- not used REAL(KIND=JPRB),ALLOCATABLE :: ZBUF(:,:,:) REAL(KIND=JPRB),ALLOCATABLE :: ZRCV(:,:) ! (D%NGPTOTMX,KFDISTG) INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG), IRECVREQ(KFDISTG) INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD INTEGER(KIND=JPIM), POINTER :: ISORT (:) LOGICAL :: LLSAME ! ------------------------------------------------------------------ IF (PRESENT (KSORT)) THEN ISORT => KSORT ELSE ALLOCATE (ISORT (KFDISTG)) DO JFLD = 1, KFDISTG ISORT (JFLD) = JFLD ENDDO ENDIF ! Copy for single PE IF(NPROC == 1) THEN !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,ISORT(JFLD),IBL) = PGPG(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ELSEIF(KFDISTG>0) THEN ! test if values in KFROM are all the same LLSAME=.TRUE. IFROM=KFROM(1) DO JFLD=2,KFDISTG IF(KFROM(JFLD) /= IFROM) THEN LLSAME=.FALSE. EXIT ENDIF ENDDO IMYFIELDS = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN IMYFIELDS = IMYFIELDS+1 ENDIF ENDDO CALL GSTATS(1663,0) IF(IMYFIELDS > 0) THEN ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)& !$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,& !$OMP&ILOFF,JGL,JLON) DO JFLD=1,IMYFIELDS DO JA=1,N_REGIONS_NS DO JB=1,N_REGIONS(JA) CALL SET2PE(ISND,JA,JB,0,0) IGLOFF = D%NPTRFRSTLAT(JA) IGL1 = D%NFRSTLAT(JA) IGL2 = D%NLSTLAT(JA) IOFF = 0 IF(JA > 1) THEN IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN ILAST = D%NLSTLAT(JA-1)-1 ELSE ILAST = D%NLSTLAT(JA-1) ENDIF DO J=D%NFRSTLAT(1),ILAST IOFF = IOFF+G%NLOEN(J) ENDDO ENDIF ILEN(ISND,JFLD) = 0 ILOFF = 0 DO JGL=IGL1,IGL2 DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB) ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = & & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD) ENDDO ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB) ILOFF = ILOFF + G%NLOEN(JGL) ENDDO ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF CALL GSTATS(1663,1) ! Message passing CALL GSTATS_BARRIER(791) CALL GSTATS(811,0) ! Receive ALLOCATE(ZRCV(D%NGPTOTMX,KFDISTG)) IF( LLSAME )THEN IRCV = KFROM(1) ITAG = MTAGDISTGP CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(1),CDSTRING='DIST_GRID_CTL:') ELSE DO JFLD=1,KFDISTG IRCV = KFROM(JFLD) ITAG = MTAGDISTGP+JFLD CALL MPL_RECV(ZRCV(:,JFLD),KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IRECVREQ(JFLD),CDSTRING='DIST_GRID_CTL:') ENDDO ENDIF ! Send IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN ITAG = MTAGDISTGP DO JROC=1,NPROC CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),& &CDSTRING='DIST_GRID_CTL') ENDDO ENDIF ELSE IFLD = 0 DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN IFLD = IFLD+1 ITAG = MTAGDISTGP+JFLD DO JROC=1,NPROC CALL MPL_SEND(ZBUF(1:ILEN(JROC,IFLD),IFLD,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,& &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,JFLD),& &CDSTRING='DIST_GRID_CTL') ENDDO ENDIF ENDDO ENDIF ! Wait for sends and receives to complete IF( LLSAME )THEN IF(KFROM(1) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), & & CDSTRING='DIST_GRID_CTL: WAIT 1') ENDIF CALL MPL_WAIT(KREQUEST=IRECVREQ(1), & & CDSTRING='DIST_GRID_CTL: WAIT 2') ELSE DO JFLD=1,KFDISTG IF(KFROM(JFLD) == MYPROC) THEN CALL MPL_WAIT(KREQUEST=ISENDREQ(:,JFLD), & & CDSTRING='DIST_GRID_CTL: WAIT 3') ENDIF CALL MPL_WAIT(KREQUEST=IRECVREQ(JFLD), & & CDSTRING='DIST_GRID_CTL: WAIT 4') ENDDO ENDIF CALL GSTATS(811,1) CALL GSTATS_BARRIER2(791) CALL GSTATS(1663,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF) DO JKGLO=1,D%NGPTOT,KPROMA IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1) IOFF = JKGLO-1 IBL = (JKGLO-1)/KPROMA+1 DO JFLD=1,KFDISTG DO JROF=1,IEND PGP(JROF,ISORT(JFLD),IBL) = ZRCV(IOFF+JROF,JFLD) ENDDO ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1663,1) DEALLOCATE(ZRCV) !Synchronize processors CALL GSTATS(786,0) CALL MPL_BARRIER(CDSTRING='DIST_GRID_CTL:') CALL GSTATS(786,1) IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF) ENDIF IF (.NOT. PRESENT (KSORT)) THEN DEALLOCATE (ISORT) ENDIF ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID_CTL END MODULE DIST_GRID_CTL_MOD ectrans-1.8.0/src/trans/cpu/internal/trmtol_mod.F900000664000175000017500000001057415174631767022354 0ustar alastairalastair! (C) Copyright 1995- ECMWF. ! (C) Copyright 1995- 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. ! MODULE TRMTOL_MOD CONTAINS SUBROUTINE TRMTOL(PFBUF_IN,PFBUF,KFIELD) !**** *trmtol * - transposition in Fourier space ! Purpose. ! -------- ! Transpose Fourier buffer data from partitioning ! over wave numbers to partitioning over latitudes. ! It is called between direct FFT and direct Legendre ! transform. ! This routine is the inverse of TRLTOM. !** Interface. ! ---------- ! *call* *trmtol(...)* ! Explicit arguments : PFBUF - Fourier coefficient buffer. It is ! -------------------- used for both input and output. ! KFIELD - Number of fields communicated ! Implicit arguments : ! -------------------- ! Method. ! ------- ! See documentation ! Externals. ! ---------- ! Reference. ! ---------- ! ECMWF Research Department documentation of the IFS ! Author. ! ------- ! MPP Group *ECMWF* ! Modifications. ! -------------- ! Original : 95-10-01 ! Modified : 97-06-17 G. Mozdzynski - control MPI mailbox use ! (NCOMBFLEN) for nphase.eq.1 ! Modified : 99-05-28 D.Salmond - Optimise copies. ! Modified : 00-02-02 M.Hamrud - Remove NPHASE ! D.Salmond : 01-11-23 LIMP_NOOLAP Option for non-overlapping message ! passing and buffer packing ! G.Mozdzynski: 08-01-01 Cleanup ! Y.Seity : 07-08-31 add barrien synchronisation under LSYNC_TRANS ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE MPL_MODULE ,ONLY : MPL_ALLTOALLV, MPL_BARRIER, MPL_ALL_MS_COMM, MPL_WAIT, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : D, MTAGML, MYSETW, NPRTRW, NPROC !USE TPM_GEN ,ONLY : LSYNC_TRANS IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KFIELD REAL(KIND=JPRB) ,INTENT(INOUT) :: PFBUF(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PFBUF_IN(:) INTEGER(KIND=JPIM) :: ILENS(NPRTRW),IOFFS(NPRTRW),ILENR(NPRTRW),IOFFR(NPRTRW) INTEGER(KIND=JPIM) :: ITAG, J, ILEN, ISTA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR2 !INTEGER(KIND=JPIM) :: IREQ ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('TRMTOL',0,ZHOOK_HANDLE) ITAG = MTAGML DO J=1,NPRTRW ILENS(J) = D%NLTSFTB(J)*KFIELD IOFFS(J) = D%NSTAGT0B(J)*KFIELD ILENR(J) = D%NLTSGTB(J)*KFIELD IOFFR(J) = D%NSTAGT0B(D%MSTABF(J))*KFIELD ENDDO IF(NPROC > 1) THEN IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR',0,ZHOOK_HANDLE_BAR) CALL GSTATS_BARRIER(764) IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR',1,ZHOOK_HANDLE_BAR) ! IF (LSYNC_TRANS) THEN ! CALL MPL_BARRIER(CDSTRING='TRMTOL') ! ENDIF CALL GSTATS(807,0) CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN,KSENDCOUNTS=ILENS,& & PRECVBUF=PFBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& & KCOMM=MPL_ALL_MS_COMM,CDSTRING='TRMTOL:') !Faster on Cray - because of peculiarity of their MPICH ! CALL MPL_ALLTOALLV(PSENDBUF=PFBUF_IN,KSENDCOUNTS=ILENS,& ! & PRECVBUF=PFBUF,KRECVCOUNTS=ILENR,KSENDDISPL=IOFFS,KRECVDISPL=IOFFR,& ! & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ,& ! & KCOMM=MPL_ALL_MS_COMM,CDSTRING='TRMTOL:') ! CALL MPL_WAIT(KREQUEST=IREQ,CDSTRING='TRMTOL: WAIT') CALL GSTATS(807,1) IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR2',0,ZHOOK_HANDLE_BAR2) CALL GSTATS_BARRIER2(764) IF (LHOOK) CALL DR_HOOK('TRMTOL_BAR2',1,ZHOOK_HANDLE_BAR2) ELSE ILEN = D%NLTSGTB(MYSETW)*KFIELD ISTA = D%NSTAGT0B(MYSETW)*KFIELD+1 CALL GSTATS(1608,0) !$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(J) DO J=ISTA,ISTA+ILEN-1 PFBUF(J) = PFBUF_IN(J) ENDDO !$OMP END PARALLEL DO CALL GSTATS(1608,1) ENDIF IF (LHOOK) CALL DR_HOOK('TRMTOL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ END SUBROUTINE TRMTOL END MODULE TRMTOL_MOD ectrans-1.8.0/src/trans/cpu/internal/fourier_in_mod.F900000664000175000017500000000473415174631767023175 0ustar alastairalastair! (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. ! MODULE FOURIER_IN_MOD CONTAINS SUBROUTINE FOURIER_IN(PREEL, KFIELDS, KGL) !**** *FOURIER_IN* - Copy fourier data from buffer to local array ! Purpose. ! -------- ! Routine for copying fourier data from buffer to local array !** Interface. ! ---------- ! CALL FOURIER_IN(...) ! Explicit arguments : PREEL - local fourier/GP array ! -------------------- KFIELDS - number of fields ! KGL - local index of latitude we are currently on ! ! Externals. None. ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2000-04-01 ! ------------------------------------------------------------------ USE PARKIND1, ONLY : JPIM, JPRB USE TPM_DISTR, ONLY : D, MYSETW USE TPM_TRANS, ONLY : FOUBUF USE TPM_GEOMETRY, ONLY : G IMPLICIT NONE REAL(KIND=JPRB), INTENT(OUT) :: PREEL(:,:) INTEGER(KIND=JPIM), INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM), INTENT(IN) :: KGL INTEGER(KIND=JPIM) :: JM, JF, IGLG, IPROC, IR, II, ISTA ! ------------------------------------------------------------------ ! Determine global latitude index corresponding to local latitude index KGL IGLG = D%NPTRLS(MYSETW) + KGL - 1 ! Loop over all zonal wavenumbers relevant for this latitude DO JM = 0, G%NMEN(IGLG) ! Get the member of the W-set responsible for this zonal wavenumber in the "m" representation IPROC = D%NPROCM(JM) ! Compute offset in FFT work array PREEL corresponding to wavenumber JM and latitude KGL IR = 2 * JM + 1 + D%NSTAGTF(KGL) II = 2 * JM + 2 + D%NSTAGTF(KGL) ! Compute offset for extraction of the fields from the m-to-l transposition buffer, FOUBUF ISTA = (D%NSTAGT0B(D%MSTABF(IPROC)) + D%NPNTGTB0(JM,KGL)) * 2 * KFIELDS ! Copy all fields from m-to-l transposition buffer to FFT work array DO JF = 1, KFIELDS PREEL(JF,IR) = FOUBUF(ISTA+2*JF-1) PREEL(JF,II) = FOUBUF(ISTA+2*JF) ENDDO ENDDO ! ------------------------------------------------------------------ END SUBROUTINE FOURIER_IN END MODULE FOURIER_IN_MODectrans-1.8.0/src/trans/cpu/algor/0000775000175000017500000000000015174631767017175 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/algor/seefmm_mix.F900000664000175000017500000003536415174631767021621 0ustar alastairalastair! (C) Copyright 2009- ECMWF. ! (C) Copyright 2013- 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. ! module seefmm_mix !**** *SEEFMM_MIX* - Implementation of Simple Exponential Expansion FMM ! Purpose. ! -------- ! Implementation of Simple Exponential Expansion FMM !** Interface. ! ---------- ! Method. ! ------- ! Based on Algorithm described in Section 4 of the article ! "An improved fast multipole algorithm for potential fields on the line " ! Reference. ! ---------- ! "An improved fast multipole algorithm for potential fields on the line " ! by Norman Yarvin and Vladimir Rohklin, SIAM J. Numer. Anal. Vol. 36,No. 2,629-666. [1] ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 2009-06-04 ! ------------------------------------------------------------------ use parkind1, only : jpim, jprb, jprd use ecsort_mix, only : keysort use wts500_mod, only: wts500 private integer(kind=jpim) :: nfmm_lim=200 ! Appr. break-even limit for FMM integer(kind=jpim),parameter :: nquadEm14=28 ! Quadrature size for eps~=1.e-14 integer(kind=jpim),parameter :: nquadEm10=20! Quadrature size for eps~=1.e-10 integer(kind=jpim),parameter :: nquadEm07=14! Quadrature size for eps~=1.e-07 type fmm_type integer(kind=jpim) :: nxy ! Total number of point "nx+ny" integer(kind=jpim) :: nx ! Number of 'x' points integer(kind=jpim) :: nquad ! Quadrature N integer(kind=jpim) :: ncik ! Number of elem. in cik real(kind=jprb) :: rw(56) ! Quadrature weights real(kind=jprb) , pointer :: rdexp(:,:) ! exp(xy(i)-xy(i-1)) integer(kind=jpim), pointer :: index(:) ! index for sorted xy integer(kind=jpim), pointer :: nclose(:) ! No of "close" points real(kind=jprb) , pointer :: cik(:) ! Correction term (142 in [1]) end type fmm_type public :: fmm_type, setup_seefmm, free_seefmm, seefmm_mulm contains recursive subroutine setup_seefmm(kx,px,ky,py,ydfmm,pdiff) implicit none !**** *SETUP_SEEFMM* - Setup seefmm ! Purpose - Pre-computations for applying SEEFMM ! Explicit arguments : ! -------------------- ! kx - Number of x points ! px - x points ! ky - Number of y points ! py - y points ! ydfmm - result of pre-computations ! pdiff - difference matrix (optional) integer(kind=jpim),intent(in) :: kx real(kind=jprd) ,intent(in) :: px(:) integer(kind=jpim),intent(in) :: ky real(kind=jprd) ,intent(in) :: py(:) type(fmm_type) ,intent(out) :: ydfmm real(kind=jprd),optional,intent(in) :: pdiff(:,:) real(kind=jprd) :: zxy(kx+ky),zcik((kx+ky)*(kx+ky)) real(kind=jprd) :: zr, zrt(56), zrw(56) real(kind=jprd), allocatable :: zrdexp(:,:) integer(kind=jpim) :: ixy !--------------------------------------------------------------------------- ydfmm%nx=kx ixy=kx+ky ydfmm%nxy=ixy allocate(ydfmm%index(ixy)) !ydfmm%nquad=nquadEm14 !Set precicion to 1.E-14 ydfmm%nquad=nquadEm07 !Set precicion to 1.E-07 ! Combine px and py to form xxy, compute ascending index for xxy call comb_xy(kx,px,ky,py,ixy,zxy,ydfmm%index) ! Setup quadrature, scale (see 3.1.1 in [1]) call suquad(ixy,zxy(ydfmm%index(1))-zxy(ydfmm%index(ixy)),ydfmm%nquad,& & zrw,zrt,zr) allocate(zrdexp(ydfmm%nquad,ixy)) allocate(ydfmm%nclose(ixy)) ! Main pre-computation call prepotf(kx,ixy,ydfmm%nquad,zrw,zrt,zr,zxy,ydfmm%index,& & zrdexp,ydfmm%nclose,zcik,ydfmm%ncik,pdiff) allocate(ydfmm%rdexp(ydfmm%nquad,ixy)) allocate(ydfmm%cik(ydfmm%ncik)) ydfmm%rw(:) = real(zrw(:),jprb) ydfmm%rdexp(:,:) = real(zrdexp(:,:),jprb) ydfmm%cik(:) = real(zcik(1:ydfmm%ncik),jprb) end subroutine setup_seefmm !========================================================================== subroutine free_seefmm(ydfmm) implicit none !**** *FREE_SEEFMM* - Release memory ! Purpose - Release memory used by ydfmm ! Explicit arguments : ! -------------------- ! ydfmm - result of pre-computations type(fmm_type) ,intent(inout) :: ydfmm deallocate(ydfmm%index) deallocate(ydfmm%rdexp) deallocate(ydfmm%nclose) deallocate(ydfmm%cik) end subroutine free_seefmm !========================================================================== recursive subroutine potf(kn,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclosel,kcik,pcik,ptheta) implicit none integer(kind=jpim),intent(in) :: kn integer(kind=jpim),intent(in) :: kx logical ,intent(in) :: ldxout integer(kind=jpim),intent(in) :: kquad real(kind=jprb) ,intent(in) :: prw(:) real(kind=jprb) ,intent(in) :: pq(:) real(kind=jprb) ,intent(in) :: prdexp(:,:) integer(kind=jpim),intent(in) :: kindex(:) integer(kind=jpim),intent(in) :: kclosel(:) integer(kind=jpim),intent(in) :: kcik real(kind=jprb) ,intent(in) :: pcik(:) real(kind=jprb) ,intent(out) :: ptheta(:) real(kind=jprb) :: zalpha(kquad),zq(kn),ztheta(kn) integer(kind=jpim) :: j1,j2,jm,inumc,idist integer(kind=jpim) :: i1,ik1,ix,iy logical :: lxy,llxy(kn) lxy(ik1) = (ik1 <= kx .eqv. ldxout) !------------------------------------------------------------------------- ztheta(:)=0.0_JPRB if(ldxout) then ix=0 iy=-kx else ix=-kx iy=0 endif do j1=1,kn i1=kindex(j1) llxy(j1)=lxy(i1) if(llxy(j1)) then zq(j1)=pq(kindex(j1)+ix) else zq(j1)=0.0_jprb endif enddo zalpha(:)=zq(1) do j1=2,kn if(llxy(j1)) then do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1)+zq(j1) enddo else do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1) ztheta(j1)=ztheta(j1)+prw(jm)*zalpha(jm) enddo endif enddo zalpha(1:kquad)=zq(kn) do j1=kn-1,1,-1 if(llxy(j1)) then do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1+1)+zq(j1) enddo else do jm=1,kquad zalpha(jm)=zalpha(jm)*prdexp(jm,j1+1) ztheta(j1)=ztheta(j1)-prw(jm)*zalpha(jm) enddo endif enddo IF(kcik > 0) then inumc=0 do j1=1,kn-1 do j2=1,kclosel(j1) idist=j2 if(.not.llxy(j1) .and. llxy(j1+idist)) then inumc=inumc+1 ztheta(j1)=ztheta(j1)-pcik(inumc)*zq(j1+idist) elseif(llxy(j1) .and. .not.llxy(j1+idist)) then inumc=inumc+1 ztheta(j1+idist)=ztheta(j1+idist)+pcik(inumc)*zq(j1) endif enddo enddo endif do j1=1,kn if(.not. llxy(j1)) then i1=kindex(j1) ptheta(i1+iy)=ztheta(j1) endif enddo end subroutine potf !========================================================================== recursive subroutine seefmm_mulv(ydfmm,ldxout,pq,ptheta) implicit none type(fmm_type) ,intent(in) :: ydfmm logical ,intent(in) :: ldxout real(kind=jprb) ,intent(in) :: pq(:) real(kind=jprb) ,intent(out) :: ptheta(:) !------------------------------------------------------------------------- call potf(ydfmm%nxy,ydfmm%nx,ldxout,ydfmm%nquad,& & ydfmm%rw,pq,ydfmm%rdexp,ydfmm%index,& & ydfmm%nclose,ydfmm%ncik,ydfmm%cik,ptheta) end subroutine seefmm_mulv !========================================================================== recursive subroutine seefmm_mulm(ydfmm,km,kskip,ldxout,pq,ptheta) implicit none type(fmm_type) ,intent(in) :: ydfmm integer(kind=jpim),intent(in) :: km integer(kind=jpim),intent(in) :: kskip logical ,intent(in) :: ldxout real(kind=jprb) ,intent(in) :: pq(:,:) real(kind=jprb) ,intent(out) :: ptheta(:,:) !------------------------------------------------------------------------- call potfm(ydfmm%nxy,km,kskip,ydfmm%nx,ldxout,ydfmm%nquad,& & ydfmm%rw,pq,ydfmm%rdexp,ydfmm%index,& & ydfmm%nclose,ydfmm%ncik,ydfmm%cik,ptheta) end subroutine seefmm_mulm !========================================================================== recursive subroutine potfm(kn,km,kskip,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclosel,kcik,pcik,ptheta) implicit none integer(kind=jpim),intent(in) :: kn integer(kind=jpim),intent(in) :: km integer(kind=jpim),intent(in) :: kskip integer(kind=jpim),intent(in) :: kx logical ,intent(in) :: ldxout integer(kind=jpim),intent(in) :: kquad real(kind=jprb) ,intent(in) :: prw(:) real(kind=jprb) ,intent(in) :: pq(:,:) real(kind=jprb) ,intent(in) :: prdexp(:,:) integer(kind=jpim),intent(in) :: kindex(:) integer(kind=jpim),intent(in) :: kclosel(:) integer(kind=jpim),intent(in) :: kcik real(kind=jprb) ,intent(in) :: pcik(:) real(kind=jprb) ,intent(out) :: ptheta(:,:) real(kind=jprb) :: zalpha(kquad,km) integer(kind=jpim) :: j1,j2,jm,jq,inumc,idist integer(kind=jpim) :: i1,i1p1,i1pd,ik1,ix,iy logical :: lxy,llxy(kn) lxy(ik1) = (ik1 <= kx .eqv. ldxout) !------------------------------------------------------------------------- !CALL GSTATS(209,0) ptheta(:,:)=0.0_JPRB if(ldxout) then ix=0 iy=-kx else ix=-kx iy=0 endif do j1=1,kn i1=kindex(j1) llxy(j1)=lxy(i1) enddo if(llxy(1)) then do jm=1,km,kskip zalpha(:,jm)=pq(jm,kindex(1)+ix) enddo else zalpha(:,:)=0.0_jprb endif !CALL GSTATS(209,1) !CALL GSTATS(210,0) do j1=2,kn i1=kindex(j1) if(llxy(j1) ) then if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo endif else if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)+prw(jq)*zalpha(jq,jm) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)+prw(jq)*zalpha(jq,jm) enddo enddo endif endif enddo !CALL GSTATS(210,1) !CALL GSTATS(211,0) if(llxy(kn)) then do jm=1,km,kskip zalpha(:,jm)=pq(jm,kindex(kn)+ix) enddo else zalpha(:,:)=0.0 endif !CALL GSTATS(211,1) !CALL GSTATS(212,0) do j1=kn-1,1,-1 i1=kindex(j1) i1p1=kindex(j1+1) if(llxy(j1)) then if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) zalpha(jq,jm)=zalpha(jq,jm)+pq(jm,i1+ix) enddo enddo endif else if( kskip==1 )then do jq=1,kquad do jm=1,km zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)-prw(jq)*zalpha(jq,jm) enddo enddo else do jq=1,kquad do jm=1,km,kskip zalpha(jq,jm)=zalpha(jq,jm)*prdexp(jq,j1+1) ptheta(jm,i1+iy)=ptheta(jm,i1+iy)-prw(jq)*zalpha(jq,jm) enddo enddo endif endif enddo !CALL GSTATS(212,1) IF(kcik > 0) then ! CALL GSTATS(213,0) inumc=0 do j1=1,kn-1 do j2=1,kclosel(j1) idist=j2 i1=kindex(j1) i1pd=kindex(j1+idist) if(.not.llxy(j1) .and. llxy(j1+idist)) then inumc=inumc+1 do jm=1,km,kskip ptheta(jm,i1+iy)=ptheta(jm,i1+iy)-pcik(inumc)*pq(jm,i1pd+ix) enddo elseif(llxy(j1) .and. .not.llxy(j1+idist)) then inumc=inumc+1 do jm=1,km,kskip ptheta(jm,i1pd+iy)=ptheta(jm,i1pd+iy)+pcik(inumc)*pq(jm,i1+ix) enddo endif enddo enddo ! CALL GSTATS(213,1) endif end subroutine potfm !========================================================================= recursive subroutine suquad(kn,prange,kquad,prw,prt,pr) implicit none integer(kind=jpim) ,intent(in) :: kn real(kind=jprd) ,intent(in) :: prange integer(kind=jpim) ,intent(in) :: kquad real(kind=jprd) ,intent(out) :: prw(:) real(kind=jprd) ,intent(out) :: prt(:) real(kind=jprd) ,intent(out) :: pr real(kind=jprd) :: za,zb,zs integer(kind=jpim) :: jm !------------------------------------------------------------------------- za=1.0_jprd zb=500.0_jprd zs=zb/prange pr=za/zs call wts500(prt,prw,kquad) do jm=1,kquad prw(jm)=prw(jm)*zs prt(jm)=prt(jm)*zs enddo end subroutine suquad !========================================================================== recursive subroutine comb_xy(kx,px,ky,py,kxy,pxy,kindex) implicit none integer(kind=jpim), intent(in) :: kx,ky real(kind=jprd), intent(in) :: px(:) real(kind=jprd), intent(in) :: py(:) integer(kind=jpim), intent(in) :: kxy real(kind=jprd), intent(out) :: pxy(:) integer(kind=jpim), intent(out) :: kindex(:) integer(kind=jpim) :: iret !------------------------------------------------------------------------- pxy(1:kx)=px(1:kx) pxy(kx+1:kx+ky)=py(1:ky) call keysort(iret,pxy,kxy,descending=.true.,index=kindex,init=.true.) end subroutine comb_xy !========================================================================== recursive subroutine prepotf(kx,kxy,kquad,prw,prt,pr,pxy,kindex,prdexp,& & kclosel,pcik,knocik,pdiff) implicit none integer(kind=jpim), intent(in) :: kx integer(kind=jpim), intent(in) :: kxy integer(kind=jpim), intent(in) :: kquad real(kind=jprd), intent(in) :: pxy(:) real(kind=jprd), intent(in) :: prw(:) real(kind=jprd), intent(in) :: pr real(kind=jprd), intent(in) :: prt(:) integer(kind=jpim), intent(in) :: kindex(:) real(kind=jprd), intent(out) :: prdexp(:,:) integer(kind=jpim), intent(out) :: kclosel(:) real(kind=jprd), intent(out) :: pcik(:) integer(kind=jpim), intent(out) :: knocik real(kind=jprd),optional, intent(in) :: pdiff(:,:) real(kind=jprd) :: zdx real(kind=jprd) :: zsum real(kind=jprd) :: zdiff(kxy,kxy) integer(kind=jpim) :: jxy,jq,isize,jdist,ixy,ixym1,i1,i1pd,j1,j2 logical :: llexit !------------------------------------------------------------------------- if(present(pdiff)) then zdiff(:,:)=pdiff(:,:) else do j1=1,kxy do j2=1,kxy zdiff(j1,j2)=pxy(j1)-pxy(j2) enddo enddo endif do jxy=2,kxy ixy=kindex(jxy) ixym1=kindex(jxy-1) do jq=1,kquad prdexp(jq,jxy)=exp(zdiff(ixy,ixym1)*prt(jq)) enddo enddo kclosel(:)=0 knocik=0 isize=size(pcik) llexit=.true. do jxy=1,kxy-1 do jdist=1,kxy-jxy i1=kindex(jxy) i1pd=kindex(jxy+jdist) zdx=zdiff(i1,i1pd) if(zdx < pr) then llexit=.false. kclosel(jxy)=kclosel(jxy)+1 if((i1 > kx .and. i1pd <= kx) .or. (i1pd > kx .and. i1 <= kx)) then knocik=knocik+1 zsum=0.0_jprd do jq=1,kquad zsum=zsum+prw(jq)*exp(-zdx*prt(jq)) enddo pcik(knocik)=1.0_jprd/zdx-zsum endif else exit endif enddo if(knocik > isize) stop ' precompfint : pcik tto small' enddo end subroutine prepotf !========================================================================== end module seefmm_mix ectrans-1.8.0/src/trans/cpu/algor/butterfly_alg_mod.F900000664000175000017500000011526615174631767023172 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! MODULE BUTTERFLY_ALG_MOD USE PARKIND1, ONLY : JPRD, JPRM, JPIM, JPRB, JPIB USE INTERPOL_DECOMP_MOD, ONLY : COMPUTE_ID USE SHAREDMEM_MOD, ONLY : SHAREDMEM, SHAREDMEM_ASSOCIATE USE ECTRANS_BLAS_MOD, ONLY : GEMM, GEMV IMPLICIT NONE PRIVATE PUBLIC NODE_TYPE,LEV_STRUCT,BUTTERFLY_STRUCT,CONSTRUCT_BUTTERFLY,MULT_BUTV,MULT_BUTM,CLONE,& & PACK_BUTTERFLY_STRUCT,UNPACK_BUTTERFLY_STRUCT ! Butterfly package. ! Butterfly algorithm for matrix multiplication ! Coded from: "An algorithm for the rapid evaluation of special function transform" by ! Michael O'Neill, Franco Woolfe and Vladimir Rohklin, Appl.Comput.Harmon.Anal. 2009? ! referred to in the following as ONWR TYPE NODE_TYPE INTEGER(KIND=JPIM) :: ILEV =0 ! Level of this node INTEGER(KIND=JPIM) :: IFCOL =0 ! First column INTEGER(KIND=JPIM) :: ILCOL =0 ! Last column INTEGER(KIND=JPIM) :: IFROW =0 ! first row INTEGER(KIND=JPIM) :: ILROW =0 ! Last row INTEGER(KIND=JPIM) :: ICOLS =0 ! Number of columns INTEGER(KIND=JPIM) :: IROWS =0 ! Number of rows INTEGER(KIND=JPIM) :: IRANK =0 ! Rank of interpolative decomposition INTEGER(KIND=JPIM) :: IOFFBETA=0 ! Offset in "beta" work space INTEGER(KIND=JPIM),POINTER :: ICLIST(:) => NULL() ! List of columns in B (column skeleton matrix) REAL(KIND=JPRB),POINTER :: PNONIM(:) => NULL() ! Non-identety part of interpolation matrix REAL(KIND=JPRB),POINTER :: B(:,:) => NULL() ! Column skeleton matrix REAL(KIND=JPRD),POINTER :: DB(:,:) => NULL() ! Column skeleton matrix, as part of pre-computations only END TYPE NODE_TYPE TYPE LEV_STRUCT INTEGER(KIND=JPIM) :: IJ =0 ! Number of row boxes at this level INTEGER(KIND=JPIM) :: IK =0 ! Number of column boxes at this level INTEGER(KIND=JPIM) :: IBETALEN=0 ! Workspace needed at this level of interim results "beta" TYPE(NODE_TYPE),POINTER :: NODE(:,:) => NULL() ! Box info END TYPE LEV_STRUCT TYPE BUTTERFLY_STRUCT INTEGER(KIND=JPIM) :: M_ORDER =0 ! M of original matrix INTEGER(KIND=JPIM) :: N_ORDER =0 ! N of original matrix INTEGER(KIND=JPIM) :: N_CMAX =0 ! Max number of columns in each submatrix at level 0 INTEGER(KIND=JPIM) :: N_LEVELS =0 ! Max level in dyadic hierarchy INTEGER(KIND=JPIM) :: IBETALEN_MAX=0 ! Max workspace for one level of interim results "beta" TYPE(LEV_STRUCT),POINTER :: SLEV(:) => NULL() ! Level structure (dimensioned 0:n_levels) END TYPE BUTTERFLY_STRUCT TYPE CLONE REAL(KIND=JPRB) , ALLOCATABLE :: COMMSBUF(:) ! for communicating packed bufferfly_structs END TYPE CLONE ! between MPI tasks CONTAINS !================================================================================ SUBROUTINE CONSTRUCT_BUTTERFLY(PEPS,KCMAX,KM,KN,PMAT,YD_STRUCT) ! Constuct butterfly REAL(KIND=JPRD),INTENT(IN) :: PEPS ! Precision INTEGER(KIND=JPIM),INTENT(IN) :: KCMAX ! Max number of columns in each submatrix at level 0 INTEGER(KIND=JPIM),INTENT(IN) :: KM ! Number of rows in matrix pmat INTEGER(KIND=JPIM),INTENT(IN) :: KN ! Number of columns in matrix pmat REAL(KIND=JPRD),INTENT(IN) :: PMAT(:,:) ! original matrix TYPE(BUTTERFLY_STRUCT),INTENT(INOUT) :: YD_STRUCT ! Structure needed to apply butterfly REAL(KIND=JPRD),ALLOCATABLE :: ZSUB(:,:),ZBCOMB(:,:) INTEGER(KIND=JPIM) :: ILEVELS,JL,JJ,JK,IJ,IK INTEGER(KIND=JPIM) :: IROWS,ICOLS INTEGER(KIND=JPIM) :: ILM1,IJL,IKL,IJR,IKR,IRANKL,IRANKR,IOFFROW,IBLEV,IBLEVM1 INTEGER(KIND=JPIM) :: IRSTRIDE,IOFFBETA TYPE(NODE_TYPE),POINTER :: YNODEL,YNODER,YNODE TYPE(NODE_TYPE),POINTER :: YBNODEL,YBNODER,YBNODE TYPE(LEV_STRUCT) :: YTEMPB(0:1) !-------------------------------------------------------------------------------- ! ONWR 5.4.1 YD_STRUCT%M_ORDER = KM YD_STRUCT%N_ORDER = KN YD_STRUCT%N_CMAX = KCMAX !Find number of levels ILEVELS = 0 DO IF(2**ILEVELS >= (YD_STRUCT%N_ORDER+YD_STRUCT%N_CMAX-1) /YD_STRUCT%N_CMAX ) EXIT ILEVELS = ILEVELS+1 ENDDO YD_STRUCT%N_LEVELS = ILEVELS ALLOCATE(YD_STRUCT%SLEV(0:YD_STRUCT%N_LEVELS)) ! Number of boxes at each level IJ = 1 IK = (KN-1)/KCMAX+1 DO JL=0,YD_STRUCT%N_LEVELS YD_STRUCT%SLEV(JL)%IJ = IJ YD_STRUCT%SLEV(JL)%IK = IK IJ = IJ*2 IK = MAX((IK+1)/2,1) ENDDO DO JL=0,YD_STRUCT%N_LEVELS ALLOCATE(YD_STRUCT%SLEV(JL)%NODE(YD_STRUCT%SLEV(JL)%IJ,YD_STRUCT%SLEV(JL)%IK)) CALL GSTATS(1253,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JJ,JK,YNODE,ILM1,IJL,IKL,IJR,IKR,IRSTRIDE) DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) YNODE%ILEV = JL IF(JL == 0) THEN YNODE%IFCOL = 1+(JK-1)*KCMAX YNODE%ILCOL = MIN(JK*KCMAX,KN) YNODE%ICOLS = YNODE%ILCOL - YNODE%IFCOL+1 YNODE%IFROW = 1 YNODE%ILROW = KM ELSE YNODE%IFCOL = -99 YNODE%ILCOL = -99 YNODE%ICOLS = -99 ILM1 = JL-1 IJL = (JJ+1)/2 IKL = 2*JK-1 IJR = (JJ+1)/2 IKR = 2*JK IRSTRIDE = (YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IROWS+1)/2 IF(MOD(JJ,2) == 1) THEN YNODE%IFROW = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IFROW YNODE%ILROW = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IFROW+IRSTRIDE -1 ELSE YNODE%IFROW = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IFROW+IRSTRIDE YNODE%ILROW = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%ILROW ENDIF ENDIF YNODE%IROWS = YNODE%ILROW - YNODE%IFROW+1 YNODE%IROWS = MAX(YNODE%IROWS,0) ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1253,1) ENDDO ! ONWR 5.4.2 DO JL=0,YD_STRUCT%N_LEVELS IBLEV = MOD(JL,2) IF(JL > 0) THEN IBLEVM1 = MOD(JL-1,2) ELSE IBLEVM1 = -1 ENDIF ALLOCATE(YTEMPB(IBLEV)%NODE(YD_STRUCT%SLEV(JL)%IJ,YD_STRUCT%SLEV(JL)%IK)) CALL GSTATS(1253,0) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JJ,JK,YNODE,YBNODE,IROWS,ICOLS,& !$OMP& ZSUB,ILM1,IJL,IKL,IJR,IKR,YNODEL,YBNODEL,IRANKL,YNODER,YBNODER,IRANKR,IOFFROW,ZBCOMB) DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) YBNODE => YTEMPB(IBLEV)%NODE(JJ,JK) IF(JL == 0) THEN IROWS=YNODE%IROWS ICOLS=YNODE%ICOLS ALLOCATE(ZSUB(IROWS,ICOLS)) CALL EXTRACT_SUB(YNODE,PMAT,ZSUB) CALL COMPRESS_MAT(YNODE,YBNODE,PEPS,IROWS,ICOLS,ZSUB) DEALLOCATE(ZSUB) ELSE ILM1 = JL-1 IJL = (JJ+1)/2 IKL = 2*JK-1 IJR = (JJ+1)/2 IKR = 2*JK YNODEL => YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL) YBNODEL => YTEMPB(IBLEVM1)%NODE(IJL,IKL) IRANKL = YNODEL%IRANK IF(IKR <= YD_STRUCT%SLEV(ILM1)%IK) THEN YNODER => YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR) YBNODER => YTEMPB(IBLEVM1)%NODE(IJR,IKR) IRANKR = YNODER%IRANK ELSE YNODER => YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL) IRANKR = 0 ENDIF IROWS = YNODE%IROWS ICOLS = IRANKL+IRANKR YNODE%ICOLS=ICOLS IOFFROW = YNODE%IFROW-& & YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IFROW ALLOCATE(ZBCOMB(IROWS,ICOLS)) CALL COMBINE_B(YBNODEL%DB,IRANKL,& & YBNODER%DB,IRANKR,& & IROWS,IOFFROW,ZBCOMB) CALL COMPRESS_MAT(YNODE,YBNODE,PEPS,IROWS,ICOLS,ZBCOMB) DEALLOCATE(ZBCOMB) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO CALL GSTATS(1253,1) IF(IBLEVM1 >= 0) THEN !Deallocate Bs no longer needed DO JJ=1,YD_STRUCT%SLEV(JL-1)%IJ DO JK=1,YD_STRUCT%SLEV(JL-1)%IK DEALLOCATE(YTEMPB(IBLEVM1)%NODE(JJ,JK)%DB) ENDDO ENDDO DEALLOCATE(YTEMPB(IBLEVM1)%NODE) ENDIF ! Permanently store B for last level IF(JL == YD_STRUCT%N_LEVELS) THEN DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) ALLOCATE(YNODE%DB(YNODE%IROWS,YNODE%IRANK)) YNODE%DB(:,:) = YTEMPB(IBLEV)%NODE(JJ,JK)%DB(:,:) DEALLOCATE(YTEMPB(IBLEV)%NODE(JJ,JK)%DB) ENDDO ENDDO DEALLOCATE(YTEMPB(IBLEV)%NODE) ENDIF ENDDO CALL GSTATS(1901,0) ! Compute work space YD_STRUCT%IBETALEN_MAX = 0 DO JL=0,YD_STRUCT%N_LEVELS IOFFBETA = 0 DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) IF( ASSOCIATED(YNODE%DB) ) THEN ALLOCATE(YNODE%B(SIZE(YNODE%DB(:,1)),SIZE(YNODE%DB(1,:)))) YNODE%B(:,:) = YNODE%DB(:,:) DEALLOCATE(YNODE%DB) ENDIF YNODE%IOFFBETA = IOFFBETA IOFFBETA = IOFFBETA+YNODE%IRANK ENDDO ENDDO YD_STRUCT%SLEV(JL)%IBETALEN = IOFFBETA YD_STRUCT%IBETALEN_MAX = MAX(YD_STRUCT%IBETALEN_MAX,YD_STRUCT%SLEV(JL)%IBETALEN) ENDDO CALL GSTATS(1901,1) RETURN END SUBROUTINE CONSTRUCT_BUTTERFLY !============================================================================= SUBROUTINE PACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE) ! Pack butterfly struct into array TYPE(BUTTERFLY_STRUCT),INTENT(IN) :: YD_STRUCT ! Structure needed to apply butterfly TYPE(CLONE), TARGET, INTENT(OUT) :: YD_CLONE ! for communicating packed bufferfly_structs INTEGER(KIND=JPIM) :: ILEN,I,JL,JIK,JIJ,J,J1,J2 !-------------------------------------------------------------------------------- ILEN=0 ILEN=ILEN+5 DO JL=0,YD_STRUCT%N_LEVELS ILEN=ILEN+3 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE) )THEN DO JIK=1,YD_STRUCT%SLEV(JL)%IK DO JIJ=1,YD_STRUCT%SLEV(JL)%IJ ILEN=ILEN+9 ILEN=ILEN+1 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST) )THEN ILEN=ILEN+SIZE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST) ENDIF ILEN=ILEN+1 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM) )THEN ILEN=ILEN+SIZE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM) ENDIF ILEN=ILEN+2 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B) )THEN ILEN=ILEN+SIZE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B) ENDIF ENDDO ENDDO ENDIF ENDDO ALLOCATE(YD_CLONE%COMMSBUF(ILEN)) I=0 YD_CLONE%COMMSBUF(I+1)=YD_STRUCT%M_ORDER YD_CLONE%COMMSBUF(I+2)=YD_STRUCT%N_ORDER YD_CLONE%COMMSBUF(I+3)=YD_STRUCT%N_CMAX YD_CLONE%COMMSBUF(I+4)=YD_STRUCT%N_LEVELS YD_CLONE%COMMSBUF(I+5)=YD_STRUCT%IBETALEN_MAX I=I+5 DO JL=0,YD_STRUCT%N_LEVELS YD_CLONE%COMMSBUF(I+1)=YD_STRUCT%SLEV(JL)%IJ YD_CLONE%COMMSBUF(I+2)=YD_STRUCT%SLEV(JL)%IK YD_CLONE%COMMSBUF(I+3)=YD_STRUCT%SLEV(JL)%IBETALEN I=I+3 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE) )THEN DO JIK=1,YD_STRUCT%SLEV(JL)%IK DO JIJ=1,YD_STRUCT%SLEV(JL)%IJ YD_CLONE%COMMSBUF(I+1)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILEV YD_CLONE%COMMSBUF(I+2)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFCOL YD_CLONE%COMMSBUF(I+3)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILCOL YD_CLONE%COMMSBUF(I+4)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFROW YD_CLONE%COMMSBUF(I+5)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILROW YD_CLONE%COMMSBUF(I+6)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICOLS YD_CLONE%COMMSBUF(I+7)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IROWS YD_CLONE%COMMSBUF(I+8)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IRANK YD_CLONE%COMMSBUF(I+9)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IOFFBETA I=I+9 YD_CLONE%COMMSBUF(I+1)=0 I=I+1 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST) )THEN J=SIZE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST) YD_CLONE%COMMSBUF(I)=J YD_CLONE%COMMSBUF(I+1:I+J)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST(:) I=I+J ENDIF YD_CLONE%COMMSBUF(I+1)=0 I=I+1 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM) )THEN J=SIZE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM) YD_CLONE%COMMSBUF(I)=J YD_CLONE%COMMSBUF(I+1:I+J)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM(:) I=I+J ENDIF YD_CLONE%COMMSBUF(I+1)=0 YD_CLONE%COMMSBUF(I+2)=0 I=I+2 IF( ASSOCIATED(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B) )THEN J1=SIZE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B,DIM=1) J2=SIZE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B,DIM=2) YD_CLONE%COMMSBUF(I-1)=J1 YD_CLONE%COMMSBUF(I )=J2 DO J=1,J2 YD_CLONE%COMMSBUF(I+1:I+J1)=YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B(:,J) I=I+J1 ENDDO ENDIF ENDDO ENDDO ENDIF ENDDO IF( I /= ILEN )THEN CALL ABOR1('PACK_BUTTERFLY_STRUCT: PACKED LENGTH /= PRECOMPUTED LENGTH') ENDIF END SUBROUTINE PACK_BUTTERFLY_STRUCT !===================================================================================== SUBROUTINE UNPACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE,YDMEMBUF) ! Construct butterfly struct from packed array TYPE(BUTTERFLY_STRUCT),INTENT(OUT) :: YD_STRUCT ! Structure needed to apply butterfly TYPE(CLONE), TARGET, OPTIONAL,INTENT(IN) :: YD_CLONE ! for communicating packed bufferfly_structs TYPE(SHAREDMEM),OPTIONAL,INTENT(INOUT) :: YDMEMBUF ! Memory buffer INTEGER(KIND=JPIM) :: I,JL,JIK,JIJ,J,J1,J2,II REAL(KIND=JPRB),POINTER :: ZBUF(:) LOGICAL :: LLMEMBUF !-------------------------------------------------------------------------------- IF(PRESENT(YDMEMBUF)) THEN LLMEMBUF = .TRUE. ELSE IF(.NOT.PRESENT(YD_CLONE)) CALL ABOR1('UNPACK_BUTTERFLY_STRUCT: YD_CLONE ARGUMENT MISSING') LLMEMBUF = .FALSE. ENDIF I=0 IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,5,ZBUF,ADVANCE=.TRUE.) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+5) ENDIF YD_STRUCT%M_ORDER = NINT(ZBUF(1),JPIM) YD_STRUCT%N_ORDER = NINT(ZBUF(2),JPIM) YD_STRUCT%N_CMAX = NINT(ZBUF(3),JPIM) YD_STRUCT%N_LEVELS = NINT(ZBUF(4),JPIM) YD_STRUCT%IBETALEN_MAX = NINT(ZBUF(5),JPIM) I=I+5 ALLOCATE(YD_STRUCT%SLEV(0:YD_STRUCT%N_LEVELS)) DO JL=0,YD_STRUCT%N_LEVELS IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,3,ZBUF,ADVANCE=.TRUE.) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+3) ENDIF YD_STRUCT%SLEV(JL)%IJ =NINT(ZBUF(1),JPIM) YD_STRUCT%SLEV(JL)%IK =NINT(ZBUF(2),JPIM) YD_STRUCT%SLEV(JL)%IBETALEN=NINT(ZBUF(3),JPIM) I=I+3 ALLOCATE(YD_STRUCT%SLEV(JL)%NODE(YD_STRUCT%SLEV(JL)%IJ,YD_STRUCT%SLEV(JL)%IK)) DO JIK=1,YD_STRUCT%SLEV(JL)%IK DO JIJ=1,YD_STRUCT%SLEV(JL)%IJ IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,10,ZBUF,ADVANCE=.TRUE.) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+10) ENDIF YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILEV = NINT(ZBUF(1),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFCOL = NINT(ZBUF(2),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILCOL = NINT(ZBUF(3),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFROW = NINT(ZBUF(4),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILROW = NINT(ZBUF(5),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICOLS = NINT(ZBUF(6),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IROWS = NINT(ZBUF(7),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IRANK = NINT(ZBUF(8),JPIM) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IOFFBETA= NINT(ZBUF(9),JPIM) J = NINT(ZBUF(10)) I=I+10 ALLOCATE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST(J)) IF( J > 0 )THEN IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,J,ZBUF,ADVANCE=.TRUE.) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+J) ENDIF DO II=1,J YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST(II)=NINT(ZBUF(II),JPIM) END DO I=I+J ENDIF IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,1,ZBUF,ADVANCE=.TRUE.) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+1) ENDIF J=NINT(ZBUF(1),JPIM) I=I+1 IF( J > 0 )THEN IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,J,YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM,ADVANCE=.TRUE.) ELSE ALLOCATE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM(J)) YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%PNONIM(:)=YD_CLONE%COMMSBUF(I+1:I+J) ENDIF I=I+J ENDIF IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,2,ZBUF,ADVANCE=.TRUE.) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+2) ENDIF J1=NINT(ZBUF(1),JPIM) J2=NINT(ZBUF(2),JPIM) I=I+2 IF( J1 > 0 .AND. J2 > 0 )THEN IF(LLMEMBUF) THEN CALL SHAREDMEM_ASSOCIATE(YDMEMBUF,J1,J2,YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B,ADVANCE=.TRUE.) I=I+J1*J2 ELSE ALLOCATE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B(J1,J2)) DO J=1,J2 YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%B(:,J)=YD_CLONE%COMMSBUF(I+1:I+J1) I=I+J1 ENDDO ENDIF ENDIF ENDDO ENDDO ENDDO IF(.NOT.LLMEMBUF) THEN IF( I /= SIZE(YD_CLONE%COMMSBUF) )THEN CALL ABOR1('UNPACK_BUTTERFLY_STRUCT: UNPACKED LENGTH /= ALLOCATED LENGTH') ENDIF ENDIF END SUBROUTINE UNPACK_BUTTERFLY_STRUCT !=========================================================================== SUBROUTINE EXTRACT_SUB(YDNODE,PMAT,PSUB) TYPE(NODE_TYPE),INTENT(IN) :: YDNODE REAL(KIND=JPRD),INTENT(IN) :: PMAT(:,:) REAL(KIND=JPRD),INTENT(OUT) :: PSUB(:,:) INTEGER(KIND=JPIM) :: ICOL,IROW,JCOL,JROW !-------------------------------------------------------------------- ICOL = 0 DO JCOL=YDNODE%IFCOL,YDNODE%ILCOL ICOL = ICOL+1 IROW = 0 DO JROW=YDNODE%IFROW,YDNODE%ILROW IROW = IROW+1 PSUB(IROW,ICOL) = PMAT(JROW,JCOL) ENDDO ENDDO END SUBROUTINE EXTRACT_SUB !=================================================================== SUBROUTINE COMBINE_B(PBL,KRANKL,PBR,KRANKR,KROWS,KOFFROW,PBCOMB) REAL(KIND=JPRD),INTENT(IN) :: PBL(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KRANKL REAL(KIND=JPRD),INTENT(IN) :: PBR(:,:) INTEGER(KIND=JPIM),INTENT(IN) :: KRANKR INTEGER(KIND=JPIM),INTENT(IN) :: KROWS INTEGER(KIND=JPIM),INTENT(IN) :: KOFFROW REAL(KIND=JPRD),INTENT(OUT) :: PBCOMB(:,:) INTEGER(KIND=JPIM) :: JCOL,JM !-------------------------------------------------------------------- DO JCOL=1,KRANKL DO JM=1,KROWS PBCOMB(JM,JCOL) = PBL(KOFFROW+JM,JCOL) ENDDO ENDDO DO JCOL=1,KRANKR DO JM=1,KROWS PBCOMB(JM,KRANKL+JCOL) = PBR(KOFFROW+JM,JCOL) ENDDO ENDDO END SUBROUTINE COMBINE_B !=================================================================== SUBROUTINE COMPRESS_MAT(YDNODE,YDBNODE,PEPS,KROWS,KCOLS,PSUB) TYPE(NODE_TYPE),INTENT(INOUT) :: YDNODE TYPE(NODE_TYPE),INTENT(INOUT) :: YDBNODE REAL(KIND=JPRD),INTENT(IN) :: PEPS INTEGER(KIND=JPIM),INTENT(IN) :: KROWS,KCOLS REAL(KIND=JPRD),INTENT(IN) :: PSUB(:,:) INTEGER(KIND=JPIM) :: JR,IRANK,ICLIST(KCOLS),JN,JM,II REAL(KIND=JPRD) :: ZSUB(KROWS,KCOLS),ZPNONIM(KROWS,KCOLS) !-------------------------------------------------------------------- II = 0 DO JN=1,KCOLS DO JM=1,KROWS II = II+1 ZSUB(JM,JN) = PSUB(JM,JN) ENDDO ENDDO CALL COMPUTE_ID(PEPS,KROWS,KCOLS,ZSUB,IRANK,ICLIST,ZPNONIM) YDNODE%IRANK = IRANK ALLOCATE(YDNODE%PNONIM(IRANK*(KCOLS-IRANK))) ALLOCATE(YDNODE%ICLIST(KCOLS)) ALLOCATE(YDBNODE%DB(KROWS,IRANK)) YDNODE%ICLIST(:) = ICLIST(1:KCOLS) II = 0 DO JN=1,KCOLS-IRANK DO JM=1,IRANK II = II+1 YDNODE%PNONIM(II) = REAL(ZPNONIM(JM,JN), JPRB) ENDDO ENDDO DO JR=1,IRANK YDBNODE%DB(:,JR) = PSUB(:,ICLIST(JR)) ENDDO END SUBROUTINE COMPRESS_MAT !==================================================================== SUBROUTINE MULT_BUTV(CDTRANS,YD_STRUCT,PVECIN,PVECOUT) ! Multiply vector by matrix represented by buttervfly TYPE(BUTTERFLY_STRUCT),INTENT(IN) :: YD_STRUCT ! Structure from constucT-butterfly CHARACTER(LEN=1),INTENT(IN) :: CDTRANS ! 'N' normal matmul, 'T' with transpose of matrix REAL(KIND=JPRB),INTENT(IN) :: PVECIN(:) ! Input vector REAL(KIND=JPRB),INTENT(OUT) :: PVECOUT(:) ! Output vector REAL(KIND=JPRB),ALLOCATABLE :: ZBETA(:,:) INTEGER(KIND=JPIM) :: JL,JJ,JK,ILEVS,IFR,ILR,IROWS INTEGER(KIND=JPIM) :: ILM1,IJL,IKL,IJR,IKR,IRANKL,IRANKR INTEGER(KIND=JPIM) :: IBETALV,IBTST,IBTEN,IBETALVM1,IBTSTL,IBTENL,IBTSTR,IBTENR REAL(KIND=JPRB) :: ZVECOUT(SIZE(PVECOUT)) LOGICAL :: LLTRANSPOSE TYPE(NODE_TYPE),POINTER :: YNODE !---------------------------------------------------------------------------------- LLTRANSPOSE = (CDTRANS == 'T' .OR. CDTRANS == 't') ILEVS = YD_STRUCT%N_LEVELS ALLOCATE(ZBETA(YD_STRUCT%IBETALEN_MAX,0:1)) ! Work space for "beta" ! ONWR 5.4.3 IF(LLTRANSPOSE) THEN DO JL=ILEVS,0,-1 IBETALV = MOD(JL,2) DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) IBTST = YNODE%IOFFBETA+1 IBTEN = YNODE%IOFFBETA+YNODE%IRANK IF(JL == 0) THEN IFR = YNODE%IFCOL ILR = YNODE%ILCOL CALL MULT_P_TR(YNODE,ZBETA(IBTST:IBTEN,IBETALV),PVECOUT(IFR:ILR)) ELSE IF(JL == ILEVS) THEN IFR = YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IFROW ILR = YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%ILROW IROWS=YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IROWS CALL GEMV('T',IROWS,YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IRANK,& & 1.0_JPRB,YNODE%B,IROWS,PVECIN(IFR:ILR),1,& & 0.0_JPRB,ZBETA(IBTST:IBTEN,IBETALV),1) ENDIF ILM1 = JL-1 IBETALVM1=MOD(ILM1,2) IJL = (JJ+1)/2 IKL = 2*JK-1 IJR = (JJ+1)/2 IKR = 2*JK IRANKL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IRANK IF(IKR <= YD_STRUCT%SLEV(ILM1)%IK) THEN IRANKR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IRANK ELSE IRANKR = 0 ENDIF IBTSTL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+1 IBTENL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+IRANKL IBTSTR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+1 IBTENR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+IRANKR CALL MULT_P_TR(YNODE,ZBETA(IBTST:IBTEN,IBETALV),ZVECOUT(1:IRANKL+IRANKR)) IF(MOD(JJ,2) == 1) THEN ZBETA(IBTSTL:IBTENL,IBETALVM1)= ZVECOUT(1:IRANKL) IF(IRANKR > 0) THEN ZBETA(IBTSTR:IBTENR,IBETALVM1)=ZVECOUT(IRANKL+1:IRANKL+IRANKR) ENDIF ELSE ZBETA(IBTSTL:IBTENL,IBETALVM1)=ZBETA(IBTSTL:IBTENL,IBETALVM1)+ & & ZVECOUT(1:IRANKL) IF(IRANKR > 0) THEN ZBETA(IBTSTR:IBTENR,IBETALVM1)=ZBETA(IBTSTR:IBTENR,IBETALVM1) + & & ZVECOUT(IRANKL+1:IRANKL+IRANKR) ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO ELSE DO JL=0,ILEVS IBETALV = MOD(JL,2) DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) IBTST = YNODE%IOFFBETA+1 IBTEN = YNODE%IOFFBETA+YNODE%IRANK IF(JL == 0) THEN ! ONWR (115) IFR = YNODE%IFCOL ILR = YNODE%ILCOL CALL MULT_P(YNODE,PVECIN(IFR:ILR),ZBETA(IBTST:IBTEN,IBETALV) ) ELSE ! ONWR (116) ILM1 = JL-1 IBETALVM1=MOD(ILM1,2) IJL = (JJ+1)/2 IKL = 2*JK-1 IJR = (JJ+1)/2 IKR = 2*JK IRANKL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IRANK IF(IKR <= YD_STRUCT%SLEV(ILM1)%IK) THEN IRANKR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IRANK ELSE IRANKR = 0 ENDIF IBTSTL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+1 IBTENL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+IRANKL IBTSTR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+1 IBTENR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+IRANKR CALL MULT_P(YNODE,ZBETA(IBTSTL:IBTENR,IBETALVM1),ZBETA(IBTST:IBTEN,IBETALV)) ENDIF IF(JL == ILEVS) THEN ! ONWR (117) IFR = YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IFROW ILR = YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%ILROW IROWS = YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IROWS CALL GEMV('N',IROWS,YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IRANK,& & 1.0_JPRB,YNODE%B,IROWS,ZBETA(IBTST:IBTEN,IBETALV),1,& & 0.0_JPRB,PVECOUT(IFR:ILR),1) ENDIF ENDDO ENDDO ENDDO ENDIF END SUBROUTINE MULT_BUTV !==================================================================== SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) ! Multiply matrix by matrix represented by butterfly CHARACTER(LEN=1),INTENT(IN) :: CDTRANS ! 'N' normal matmul, 'T' with transpose of matrix TYPE(BUTTERFLY_STRUCT),INTENT(IN) :: YD_STRUCT ! Structure from constucT-butterfly INTEGER(KIND=JPIM),INTENT(IN) :: KF ! Number of fields INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN) :: KWV ! zonal wave number m (special_case) REAL(KIND=JPRB),INTENT(IN) :: PVECIN(:,:) ! Input vector REAL(KIND=JPRB),INTENT(OUT) :: PVECOUT(:,:) ! Output vector INTEGER(KIND=JPIM) :: JL,JJ,JK,ILEVS,IFR,ILR,IROWS,JF INTEGER(KIND=JPIM) :: ILM1,IJL,IKL,IJR,IKR,IRANKL,IRANKR,IROUT,IRIN INTEGER(KIND=JPIM) :: IRANK,IM,IN,JN,JM,IDX,IKWV,II INTEGER(KIND=JPIM) :: IBETALV,IBTST,IBTEN,IBETALVM1,IBTSTL,IBTENL,IBTSTR,IBTENR,ILBETA REAL(KIND=JPRB) :: ZVECIN(YD_STRUCT%N_ORDER,KF),ZVECOUT(YD_STRUCT%N_ORDER,KF) REAL(KIND=JPRB),ALLOCATABLE :: ZBETA(:,:,:) LOGICAL :: LLTRANSPOSE ! IKWV==0 only, LLTRANSPOSE = true only REAL(KIND=JPRD),ALLOCATABLE :: ZPNONIM_D(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZBETA_D(:,:), ZB_D(:,:) REAL(KIND=JPRD),ALLOCATABLE :: ZOUT_D(:,:), ZIN_D(:,:) TYPE(NODE_TYPE),POINTER :: YNODE IKWV=10 IF( PRESENT(KWV) ) THEN IKWV=KWV ENDIF !---------------------------------------------------------------------------------- LLTRANSPOSE = (CDTRANS == 'T' .OR. CDTRANS == 't') IROUT=SIZE(PVECOUT(:,1)) IRIN=SIZE(PVECIN(:,1)) ILEVS = YD_STRUCT%N_LEVELS ILBETA = YD_STRUCT%IBETALEN_MAX ALLOCATE(ZBETA(ILBETA,KF,0:1)) ! Work space for "beta" ! ONWR 5.4.3 IF (LLTRANSPOSE) THEN IF (IKWV == 0 .AND. JPRB /= JPRD) THEN ALLOCATE(ZBETA_D(ILBETA,KF)) ALLOCATE(ZOUT_D(YD_STRUCT%N_ORDER,KF)) ALLOCATE(ZIN_D(IRIN,KF)) ENDIF DO JL=ILEVS,0,-1 IBETALV = MOD(JL,2) DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) IBTST = YNODE%IOFFBETA+1 IBTEN = YNODE%IOFFBETA+YNODE%IRANK IF(JL == 0) THEN IFR = YNODE%IFCOL ILR = YNODE%ILCOL IN = YNODE%ICOLS-YNODE%IRANK IM = YNODE%IRANK IF( IM <=0 ) CALL ABOR1('mult_butm: IM<=0 not allowed') IF(IN>0) THEN ! Force GEMMs for the zeroth wavenumber to be double precision IF (IKWV == 0 .AND. JPRB /= JPRD) THEN ALLOCATE(ZPNONIM_D(IM,IN)) II = 0 DO JN = 1, IN DO JM = 1, IM II = II + 1 ZPNONIM_D(JM,JN) = REAL(YNODE%PNONIM(II),JPRD) ENDDO ENDDO ZBETA_D(1:IM,1:KF) = REAL(ZBETA(IBTST:IBTST+IM-1,1:KF,IBETALV),JPRD) CALL GEMM('T', 'N', & & IN, KF, IM, & & 1.0_JPRD, & & ZPNONIM_D(1,1), IM, & & ZBETA_D(1,1), ILBETA, & & 0.0_JPRD, & & ZOUT_D(1,1), YD_STRUCT%N_ORDER) ZVECOUT(YNODE%IRANK+1:YNODE%IRANK+IN,1:KF) = REAL(ZOUT_D(1:IN,1:KF),JPRB) DEALLOCATE(ZPNONIM_D) ELSE CALL GEMM('T', 'N', & & IN, KF, IM, & & 1.0_JPRB, & & YNODE%PNONIM(1), IM, & & ZBETA(IBTST,1,IBETALV), ILBETA, & & 0.0_JPRB, & & ZVECOUT(YNODE%IRANK+1,1), YD_STRUCT%N_ORDER) ENDIF ENDIF DO JF=1,KF DO JN=1,YNODE%IRANK IDX = YNODE%ICLIST(JN) PVECOUT(IFR+IDX-1,JF) = ZBETA(IBTST+JN-1,JF,IBETALV) ENDDO DO JN=YNODE%IRANK+1,YNODE%ICOLS IDX = YNODE%ICLIST(JN) PVECOUT(IFR+IDX-1,JF) = ZVECOUT(JN,JF) ENDDO ENDDO ELSE IF(JL == ILEVS) THEN IFR = YNODE%IFROW ILR = YNODE%ILROW IROWS =YNODE%IROWS IRANK = YNODE%IRANK ! Force GEMMs for the zeroth wavenumber to be double precision IF (IKWV == 0 .AND. JPRB /= JPRD) THEN ALLOCATE(ZB_D(IROWS,IRANK)) ZB_D(1:IROWS,1:IRANK) = REAL(YNODE%B(1:IROWS,1:IRANK),JPRD) ZIN_D(1:ILR-IFR+1,1:KF) = REAL(PVECIN(IFR:ILR,1:KF),JPRD) CALL GEMM('T', 'N', & & IRANK, KF, IROWS, & & 1.0_JPRD, & & ZB_D, IROWS, & & ZIN_D, IRIN, & & 0.0_JPRD, & & ZBETA_D, ILBETA) ZBETA(IBTST:IBTST+IRANK-1,1:KF,IBETALV) = REAL(ZBETA_D(1:IRANK,1:KF),JPRM) DEALLOCATE(ZB_D) ELSE CALL GEMM('T', 'N', & & IRANK, KF, IROWS, & & 1.0_JPRB, & & YNODE%B(1,1), IROWS, & & PVECIN(IFR,1), IRIN, & & 0.0_JPRB, & & ZBETA(IBTST,1,IBETALV), ILBETA) END IF ENDIF ILM1 = JL-1 IBETALVM1=MOD(ILM1,2) IJL = (JJ+1)/2 IKL = 2*JK-1 IJR = (JJ+1)/2 IKR = 2*JK IRANKL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IRANK IBTSTL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+1 IBTENL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+IRANKL IF(IKR <= YD_STRUCT%SLEV(ILM1)%IK) THEN IRANKR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IRANK IBTSTR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+1 IBTENR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+IRANKR ELSE IRANKR = 0 ENDIF IN = YNODE%ICOLS-YNODE%IRANK IM = YNODE%IRANK IF( IM <=0 ) CALL ABOR1('mult_butm: IM<=0 not allowed') IF(IN>0) THEN ! Force GEMMs for the zeroth wavenumber to be double precision IF (IKWV == 0 .AND. JPRB /= JPRD) THEN ALLOCATE(ZPNONIM_D(IM,IN)) II = 0 DO JN = 1, IN DO JM = 1, IM II = II + 1 ZPNONIM_D(JM,JN) = REAL(YNODE%PNONIM(II),JPRD) ENDDO ENDDO ZBETA_D(1:IM,1:KF) = REAL(ZBETA(IBTST:IBTST+IM-1,1:KF,IBETALV),JPRD) CALL GEMM('T', 'N', & & IN, KF, IM, & & 1.0_JPRD, & & ZPNONIM_D, IM, & & ZBETA_D, ILBETA, & & 0.0_JPRD,& & ZOUT_D, YD_STRUCT%N_ORDER) ZVECOUT(YNODE%IRANK+1:YNODE%IRANK+IN,1:KF) = REAL(ZOUT_D(1:IN,1:KF),JPRM) DEALLOCATE(ZPNONIM_D) ELSE CALL GEMM('T', 'N', & & IN, KF, IM, & & 1.0_JPRB, & & YNODE%PNONIM(1), IM, & & ZBETA(IBTST,1,IBETALV), ILBETA, & & 0.0_JPRB, & & ZVECOUT(YNODE%IRANK+1,1), YD_STRUCT%N_ORDER) ENDIF ENDIF DO JF=1,KF DO JN=1,YNODE%IRANK IDX = YNODE%ICLIST(JN) ZVECIN(IDX,JF) = ZBETA(IBTST+JN-1,JF,IBETALV) ENDDO DO JN=YNODE%IRANK+1,YNODE%ICOLS IDX = YNODE%ICLIST(JN) ZVECIN(IDX,JF) = ZVECOUT(JN,JF) ENDDO ENDDO DO JF=1,KF IF(MOD(JJ,2) == 1) THEN ZBETA(IBTSTL:IBTENL,JF,IBETALVM1)= ZVECIN(1:IRANKL,JF) IF(IRANKR > 0) THEN ZBETA(IBTSTR:IBTENR,JF,IBETALVM1)=ZVECIN(IRANKL+1:IRANKL+IRANKR,JF) ENDIF ELSE ZBETA(IBTSTL:IBTENL,JF,IBETALVM1)=ZBETA(IBTSTL:IBTENL,JF,IBETALVM1)+ & & ZVECIN(1:IRANKL,JF) IF(IRANKR > 0) THEN ZBETA(IBTSTR:IBTENR,JF,IBETALVM1)=ZBETA(IBTSTR:IBTENR,JF,IBETALVM1) + & & ZVECIN(IRANKL+1:IRANKL+IRANKR,JF) ENDIF ENDIF ENDDO ENDIF ENDDO ENDDO ENDDO IF (IKWV == 0 .AND. JPRB /= JPRD) THEN DEALLOCATE(ZBETA_D) DEALLOCATE(ZOUT_D) DEALLOCATE(ZIN_D) ENDIF ELSE DO JL=0,ILEVS IBETALV = MOD(JL,2) DO JJ=1,YD_STRUCT%SLEV(JL)%IJ DO JK=1,YD_STRUCT%SLEV(JL)%IK YNODE => YD_STRUCT%SLEV(JL)%NODE(JJ,JK) IBTST = YNODE%IOFFBETA+1 IBTEN = YNODE%IOFFBETA+YNODE%IRANK IF(JL == 0) THEN IFR = YNODE%IFCOL ILR = YNODE%ILCOL IRANK = YNODE%IRANK IM = IRANK IN = YNODE%ICOLS-IRANK DO JF=1,KF DO JN=1,YNODE%ICOLS IDX = YNODE%ICLIST(JN) IF(JN <= IRANK) THEN ZBETA(IBTST+JN-1,JF,IBETALV) = PVECIN(IFR+IDX-1,JF) ELSE ZVECIN(JN,JF) = PVECIN(IFR+IDX-1,JF) ENDIF ENDDO ENDDO IF( IRANK <=0 ) CALL ABOR1('mult_butm: IRANK<=0 not allowed') IF(YNODE%ICOLS > IRANK) THEN CALL GEMM('N','N',IRANK,KF,IN,1.0_JPRB,& & YNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YD_STRUCT%N_ORDER,1.0_JPRB,& & ZBETA(IBTST,1,IBETALV),ILBETA) ENDIF ELSE ILM1 = JL-1 IBETALVM1=MOD(ILM1,2) IJL = (JJ+1)/2 IKL = 2*JK-1 IJR = (JJ+1)/2 IKR = 2*JK IRANKL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IRANK IBTSTL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+1 IBTENL = YD_STRUCT%SLEV(ILM1)%NODE(IJL,IKL)%IOFFBETA+IRANKL IF(IKR <= YD_STRUCT%SLEV(ILM1)%IK) THEN IRANKR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IRANK IBTSTR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+1 IBTENR = YD_STRUCT%SLEV(ILM1)%NODE(IJR,IKR)%IOFFBETA+IRANKR ELSE IRANKR = 0 IBTENR = IBTENL ENDIF IRANK = YNODE%IRANK IM = IRANK IN = YNODE%ICOLS-IRANK DO JF=1,KF DO JN=1,YNODE%ICOLS IDX = YNODE%ICLIST(JN) IF(JN <= IRANK) THEN ZBETA(IBTST+JN-1,JF,IBETALV) = ZBETA(IBTSTL+IDX-1,JF,IBETALVM1) ELSE ZVECIN(JN,JF) = ZBETA(IBTSTL+IDX-1,JF,IBETALVM1) ENDIF ENDDO ENDDO IF( IRANK <=0 ) CALL ABOR1('mult_butm: IRANK<=0 not allowed') IF(YNODE%ICOLS > IRANK) THEN CALL GEMM('N','N',IRANK,KF,IN,1.0_JPRB,& & YNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YD_STRUCT%N_ORDER,1.0_JPRB,& & ZBETA(IBTST,1,IBETALV),ILBETA) ENDIF ENDIF IF( IRANK <=0 ) CALL ABOR1('mult_butm: IRANK<=0 not allowed') IF(JL == ILEVS) THEN IFR = YNODE%IFROW ILR = YNODE%ILROW IROWS = YNODE%IROWS CALL GEMM('N','N',IROWS,KF,YNODE%IRANK,1.0_JPRB,& & YNODE%B(1,1),IROWS,ZBETA(IBTST,1,IBETALV),YD_STRUCT%IBETALEN_MAX,0.0_JPRB,& & PVECOUT(IFR,1),IROUT) ENDIF ENDDO ENDDO ENDDO ENDIF DEALLOCATE(ZBETA) END SUBROUTINE MULT_BUTM !===================================================================== SUBROUTINE MULT_P(YDNODE,PVECIN,PVECOUT) ! Multiply vector by projection matrix TYPE(NODE_TYPE),INTENT(INOUT) :: YDNODE REAL(KIND=JPRB),INTENT(IN) :: PVECIN(:) REAL(KIND=JPRB),INTENT(OUT) :: PVECOUT(:) REAL(KIND=JPRB) :: ZVECIN(YDNODE%ICOLS) INTEGER(KIND=JPIM) :: JN, IDX, IRANK, IM, IN !--------------------------------------------------------- IRANK = YDNODE%IRANK DO JN = 1, YDNODE%ICOLS IDX = YDNODE%ICLIST(JN) IF (JN <= IRANK) THEN PVECOUT(JN) = PVECIN(IDX) ELSE ZVECIN(JN) = PVECIN(IDX) ENDIF ENDDO IF (YDNODE%ICOLS > IRANK) THEN IM = IRANK IN = YDNODE%ICOLS-IRANK CALL GEMV('N', & & IM, IN, & & 1.0_JPRB, & & YDNODE%PNONIM(1), IRANK, & & ZVECIN(IRANK+1), 1, & & 1.0_JPRB, & & PVECOUT(1), 1) ENDIF END SUBROUTINE MULT_P !===================================================================== SUBROUTINE MULT_PM(YDNODE,KF,KLBETA,PVECIN,PVECOUT) ! Multiply matrix by projection matrix TYPE(NODE_TYPE),INTENT(INOUT) :: YDNODE INTEGER(KIND=JPIM),INTENT(IN) :: KF INTEGER(KIND=JPIM),INTENT(IN) :: KLBETA REAL(KIND=JPRB),INTENT(IN) :: PVECIN(:,:) REAL(KIND=JPRB),INTENT(OUT) :: PVECOUT(:,:) REAL(KIND=JPRB) :: ZVECIN(YDNODE%ICOLS,KF), ZVECOUT(SIZE(PVECOUT(:,1)),KF) INTEGER(KIND=JPIM) :: JN,IDX,IRANK,IM,IN,JF !--------------------------------------------------------- IRANK = YDNODE%IRANK IM = IRANK IN = YDNODE%ICOLS-IRANK DO JF=1,KF DO JN=1,YDNODE%ICOLS IDX = YDNODE%ICLIST(JN) IF(JN <= IRANK) THEN ZVECOUT(JN,JF) = PVECIN(IDX,JF) ELSE ZVECIN(JN,JF) = PVECIN(IDX,JF) ENDIF ENDDO ENDDO IF (YDNODE%ICOLS > IRANK) THEN CALL GEMM('N','N',IRANK,KF,IN,1.0_JPRB,& & YDNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YDNODE%ICOLS,1.0_JPRB,& & PVECOUT(1,1),IRANK) ENDIF END SUBROUTINE MULT_PM !================================================================== SUBROUTINE MULT_P_TR(YDNODE, PVECIN, PVECOUT) ! Multiply vector by transposed procetion matrix TYPE(NODE_TYPE),INTENT(INOUT) :: YDNODE REAL(KIND=JPRB),INTENT(IN) :: PVECIN(:) REAL(KIND=JPRB),INTENT(OUT) :: PVECOUT(:) REAL(KIND=JPRB) :: ZVECOUT(YDNODE%ICOLS) INTEGER(KIND=JPIM) :: JK, JN, IDX, IRANK, IM, IN !--------------------------------------------------------- IRANK = YDNODE%IRANK IN = YDNODE%ICOLS-IRANK IF (IN > 0) THEN IM = IRANK CALL GEMV('T', & & IM, IN,& & 1.0_JPRB, & & YDNODE%PNONIM(1), IRANK, & & PVECIN(1), 1, & & 0.0_JPRB, & & ZVECOUT(IRANK+1), 1) ENDIF DO JK = 1, IRANK IDX = YDNODE%ICLIST(JK) PVECOUT(IDX) = PVECIN(JK) ENDDO DO JN = IRANK + 1,YDNODE%ICOLS IDX = YDNODE%ICLIST(JN) PVECOUT(IDX) = ZVECOUT(JN) ENDDO END SUBROUTINE MULT_P_TR !================================================================== SUBROUTINE MULT_P_TRM(YDNODE, KF, PVECIN, PVECOUT) ! Multiply matrix by transposed procetion matrix TYPE(NODE_TYPE),INTENT(INOUT) :: YDNODE INTEGER(KIND=JPIM),INTENT(IN) :: KF REAL(KIND=JPRB),INTENT(IN) :: PVECIN(:,:) REAL(KIND=JPRB),INTENT(OUT) :: PVECOUT(:,:) REAL(KIND=JPRB) :: ZVECOUT(YDNODE%ICOLS,KF) INTEGER(KIND=JPIM) :: JK, JN, IDX, IM, IN, JF !------------------------------------------------------------------ IN = YDNODE%ICOLS-YDNODE%IRANK IM = YDNODE%IRANK IF (IN > 0) THEN CALL GEMM('T', 'N', & & IN, KF, IM, & & 1.0_JPRB, & & YDNODE%PNONIM(1), IM, & & PVECIN(1,1), IM, & & 0.0_JPRB, & & ZVECOUT(YDNODE%IRANK+1,1),YDNODE%ICOLS) ENDIF DO JF = 1, KF DO JK = 1, YDNODE%IRANK IDX = YDNODE%ICLIST(JK) PVECOUT(IDX,JF) = PVECIN(JK,JF) ENDDO DO JN = YDNODE%IRANK + 1, YDNODE%ICOLS IDX = YDNODE%ICLIST(JN) PVECOUT(IDX,JF) = ZVECOUT(JN,JF) ENDDO ENDDO END SUBROUTINE MULT_P_TRM !==================================================================== END MODULE BUTTERFLY_ALG_MOD ectrans-1.8.0/src/trans/cpu/external/0000775000175000017500000000000015174631767017713 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/external/dir_transad.F900000664000175000017500000004433615174631767022477 0ustar alastairalastair! (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 DIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANSAD* - Direct spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the direct spectral transform - adjoint !** Interface. ! ---------- ! CALL DIR_TRANSAD(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 resolution (input) ! PGP(:,:,:) - gridpoint fields (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIR_TRANS_CTLAD - control routine ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, & & NGPBLKS, NF_SC2, NF_SC3A, NF_SC3B, NPROMA USE TPM_DISTR ,ONLY : D, MYSETV, NPRTRV USE SET_RESOL_MOD ,ONLY : SET_RESOL USE DIR_TRANS_CTLAD_MOD ,ONLY : DIR_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(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) 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 REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIR_TRANSAD',0,ZHOOK_HANDLE) CALL GSTATS(1810,0) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT LSCDERS=.FALSE. ! This is for use in TRLTOG which is shared with inverse transform LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANSAD:KVSETUV 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 ENDIF IF(PRESENT(KVSETSC)) THEN IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC 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('DIR_TRANSAD:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANSAD:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANSAD:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANSAD : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPVOR,1) < IF_UV ',& & UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANSAD : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= IF_UV) THEN WRITE(NERR,*)'DIR_TRANSAD : UBOUND(PSPDIV,1) < IF_UV ',& & UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANSAD : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANSAD : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_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('DIR_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('DIR_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('DIR_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('DIR_TRANSAD: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANSAD:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANSAD:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANSAD:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANSAD:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANSAD:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANSAD:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_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,*)'DIR_TRANSAD:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANSAD:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANSAD:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANSAD:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANSAD:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANSAD:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANSAD:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANSAD:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANSAD:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANSAD:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANSAD:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANSAD:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANSAD:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANSAD:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANSAD:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANSAD:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANSAD:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANSAD:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1810,1) ! Perform transform CALL DIR_TRANS_CTLAD(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LHOOK) CALL DR_HOOK('DIR_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE DIR_TRANSAD ectrans-1.8.0/src/trans/cpu/external/dir_trans.F900000664000175000017500000004470315174631767022170 0ustar alastairalastair! (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 DIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & LDLATLON,KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANS* - Direct spectral transform (from grid-point to spectral). ! Purpose. ! -------- ! Interface routine for the direct spectral transform !** Interface. ! ---------- ! CALL DIR_TRANS(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! LDLATLON - indicating if regular lat-lon is the input data ! 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 resolution (input) ! PGP(:,:,:) - gridpoint fields (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - 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 USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, LATLON, & & NF_SC2, NF_SC3A, NF_SC3B, & & NGPBLKS, NPROMA USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV USE SET_RESOL_MOD ,ONLY : SET_RESOL USE DIR_TRANS_CTL_MOD ,ONLY : DIR_TRANS_CTL 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(:,:) 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 LOGICAL ,OPTIONAL, INTENT(IN) :: LDLATLON 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 variables INTEGER(KIND=JPIM) :: IUBOUND(4),J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IF_SCALARS,IF_SCALARS_G,IF_FS,IF_GP INTEGER(KIND=JPIM) :: IF_SC2_G,IF_SC3A_G,IF_SC3B_G REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIR_TRANS',0,ZHOOK_HANDLE) CALL GSTATS(1808,0) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 IF_SCALARS = 0 IF_SCALARS_G = 0 NF_SC2 = 0 NF_SC3A = 0 NF_SC3B = 0 IF_SC2_G = 0 IF_SC3A_G = 0 IF_SC3B_G = 0 NPROMA = D%NGPTOT ! This is for use in TRGTOL which is shared with adjoint inverse transform LSCDERS=.FALSE. LVORGP=.FALSE. LDIVGP=.FALSE. LUVDER=.FALSE. LATLON=.FALSE. ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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 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,*) 'DIR_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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('DIR_TRANS:KVSETSC2 BUT NOT PSPSC2') ENDIF IF_SC2_G = UBOUND(KVSETSC2,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC2_G DO J=1,UBOUND(KVSETSC2,1) IF(KVSETSC2(J) > NPRTRV .OR. KVSETSC2(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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) NF_SC2 = UBOUND(PSPSC2,1) IF_SCALARS = IF_SCALARS+NF_SC2 IF_SCALARS_G = IF_SCALARS_G +IF_SC2_G ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3A BUT NOT PSPSC3A') ENDIF IF_SC3A_G = UBOUND(KVSETSC3A,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3A_G*UBOUND(PSPSC3A,3) DO J=1,UBOUND(KVSETSC3A,1) IF(KVSETSC3A(J) > NPRTRV .OR. KVSETSC3A(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3A,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3A_G*UBOUND(PSPSC3A,3) NF_SC3A = UBOUND(PSPSC3A,1) ENDIF IF(PRESENT(KVSETSC3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:KVSETSC3B BUT NOT PSPSC3B') ENDIF IF_SC3B_G = UBOUND(KVSETSC3B,1) IF_SCALARS_G = IF_SCALARS_G+IF_SC3B_G*UBOUND(PSPSC3B,3) DO J=1,UBOUND(KVSETSC3B,1) IF(KVSETSC3B(J) > NPRTRV .OR. KVSETSC3B(J) < 1) THEN WRITE(NERR,*) 'DIR_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('DIR_TRANS: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_G = UBOUND(PSPSC3B,1) IF_SCALARS_G = IF_SCALARS_G +IF_SC3B_G*UBOUND(PSPSC3B,3) NF_SC3B = UBOUND(PSPSC3B,1) ENDIF IF(PRESENT(KPROMA)) THEN NPROMA = KPROMA ENDIF IF(PRESENT(LDLATLON)) THEN LATLON = LDLATLON ENDIF ! Compute derived variables NGPBLKS = (D%NGPTOT-1)/NPROMA+1 IF_FS = 2*IF_UV + IF_SCALARS IF_GP = 2*IF_UV_G+IF_SCALARS_G ! Consistency checks IF (IF_UV > 0) THEN IF(.NOT. PRESENT(PSPVOR) ) THEN CALL ABORT_TRANS('DIR_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('DIR_TRANS : PSPVOR PRESENT BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) /= IF_UV) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('DIR_TRANS : INCONSISTENT FIRST DIM. OF PSPVOR AND PSPDIV') ENDIF ENDIF IF (IF_SCALARS > 0) THEN IF(PRESENT(PSPSCALAR)) THEN IF(UBOUND(PSPSCALAR,1) < IF_SCALARS) THEN WRITE(NERR,*)'DIR_TRANS : UBOUND(PSPSCALAR,1) < IF_SCALARS) ',& & UBOUND(PSPSCALAR,1),IF_SCALARS CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR TOO SHORT') ENDIF IF(PRESENT(PSPSC3A))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3A BOTH PRESENT') ENDIF IF(PRESENT(PSPSC3B))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC3B BOTH PRESENT') ENDIF IF(PRESENT(PSPSC2))THEN CALL ABORT_TRANS('DIR_TRANS : PSPSCALAR AND PSPSC2 BOTH PRESENT') ENDIF ENDIF 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: 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('DIR_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),IF_GP CALL ABORT_TRANS('DIR_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < 2) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),2 CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('DIR_TRANS: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,*)'DIR_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3A HAS TO BE PRESENT WHEN PGP3A IS') ENDIF ENDIF IF(IF_SC3A_G > 0) THEN IF(PRESENT(PGP3A)) THEN IUBOUND=UBOUND(PGP3A) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3A,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3A,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('DIR_TRANS:PSPSC3B HAS TO BE PRESENT WHEN PGP3B IS') ENDIF ENDIF IF(IF_SC3B_G > 0) THEN IF(PRESENT(PGP3B)) THEN IUBOUND=UBOUND(PGP3B) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'DIR_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('DIR_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G) THEN WRITE(NOUT,*)'DIR_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G CALL ABORT_TRANS('DIR_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= UBOUND(PSPSC3B,3) ) THEN WRITE(NOUT,*)'DIR_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),UBOUND(PSPSC3B,3) CALL ABORT_TRANS('DIR_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'DIR_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('DIR_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('DIR_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1808,1) ! ------------------------------------------------------------------ CALL DIR_TRANS_CTL(IF_UV_G,IF_SCALARS_G,IF_GP,IF_FS,IF_UV,IF_SCALARS,& & PSPVOR,PSPDIV,PSPSCALAR,KVSETUV,KVSETSC,PGP,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LHOOK) CALL DR_HOOK('DIR_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE DIR_TRANS ectrans-1.8.0/src/trans/cpu/external/specnorm.F900000664000175000017500000000711215174631767022022 0ustar alastairalastair! (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 SPECNORM(PNORM,PSPEC,KVSET,KMASTER,KRESOL,PMET) !**** *SPECNORM* - Compute global spectral norms ! Purpose. ! -------- ! Interface routine for computing spectral norms !** Interface. ! ---------- ! CALL SPECNORM(...) ! Explicit arguments : All arguments optional ! -------------------- ! PSPEC(:,:) - Spectral array ! KVSET(:) - "B-Set" for each field ! KMASTER - processor to recieve norms ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PMET(:) - metric ! PNORM(:) - Norms (output for processor KMASTER) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- SPNORM_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DISTR ,ONLY : D, NPRTRV, MYSETV, MYPROC USE SET_RESOL_MOD ,ONLY : SET_RESOL USE SPNORM_CTL_MOD ,ONLY : SPNORM_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) , INTENT(OUT) :: PNORM(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE INTEGER(KIND=JPIM) :: IMASTER,IFLD,IFLD_G,J ! ------------------------------------------------------------------ ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults IMASTER = 1 IFLD = 0 IF(PRESENT(KMASTER)) THEN IMASTER = KMASTER ENDIF IF(PRESENT(KVSET)) THEN IFLD_G = UBOUND(KVSET,1) DO J=1,IFLD_G IF(KVSET(J) > NPRTRV) THEN WRITE(NERR,*) 'SPECNORM:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('SPECNORM:KVSET TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFLD = IFLD+1 ENDIF ENDDO ELSE IF(PRESENT(PSPEC)) THEN IFLD = UBOUND(PSPEC,1) ENDIF IFLD_G = IFLD ENDIF IF(NPRTRV >1) THEN IF(IFLD > 0 .AND. .NOT. PRESENT(KVSET)) THEN WRITE(NERR,*)'NPRTRV >1 AND IFLD > 0 AND NOT PRESENT(KVSET)',& &NPRTRV,IFLD CALL ABORT_TRANS('SPECNORM: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(MYPROC == IMASTER) THEN IF(UBOUND(PNORM,1) < IFLD_G) THEN CALL ABORT_TRANS('SPECNORM: PNORM TOO SMALL') ENDIF ENDIF IF(IFLD > 0 ) THEN IF(.NOT. PRESENT(PSPEC)) THEN CALL ABORT_TRANS('SPECNORM: PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,1) < IFLD) THEN CALL ABORT_TRANS('SPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,2) < D%NSPEC2) THEN CALL ABORT_TRANS('SPECNORM: FIRST DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL SPNORM_CTL(PNORM,PSPEC,IFLD,IFLD_G,KVSET,IMASTER,PMET) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE SPECNORM ectrans-1.8.0/src/trans/cpu/external/trans_release.F900000664000175000017500000000256515174631767023032 0ustar alastairalastair! (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 TRANS_RELEASE(KRESOL) !**** *TRANS_RELEASE* - release a spectral resolution ! Purpose. ! -------- ! Release all arrays related to a given resolution tag !** Interface. ! ---------- ! CALL TRANS_RELEASE ! Explicit arguments : KRESOL : resolution tag ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 09-Jul-2013 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM !ifndef INTERFACE USE DEALLOC_RESOL_MOD ,ONLY : DEALLOC_RESOL ! IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL !endif INTERFACE ! ------------------------------------------------------------------ CALL DEALLOC_RESOL(KRESOL) ! ------------------------------------------------------------------ END SUBROUTINE TRANS_RELEASE ectrans-1.8.0/src/trans/cpu/external/trans_inq.F900000664000175000017500000004211015174631767022167 0ustar alastairalastair! (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 TRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& &KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& &KMYMS,KASM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& &KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& &KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& &KULTPP,KPTRLS,KNMENG,& &KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& &LDSPLITLAT,& &KSMAX,PLAPIN,KNVALUE,KDEF_RESOL,LDLAM,& &PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KDGLU) !**** *TRANS_INQ* - Extract information from the transform package ! Purpose. ! -------- ! Interface routine for extracting information from the T.P. !** Interface. ! ---------- ! CALL TRANS_INQ(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resolution (input) ! MULTI-TRANSFORMS MANAGEMENT ! KDEF_RESOL - number or resolutions defined ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! SPECTRAL SPACE ! KSPEC - number of complex spectral coefficients on this PE ! KSPEC2 - 2*KSPEC ! KSPEC2G - global KSPEC2 ! KSPEC2MX - maximun KSPEC2 among all PEs ! KNUMP - Number of spectral waves handled by this PE ! KGPTOT - Total number of grid columns on this PE ! KGPTOTG - Total number of grid columns on the Globe ! KGPTOTMX - Maximum number of grid columns on any of the PEs ! KGPTOTL - Number of grid columns one each PE (dimension N_REGIONS_NS:N_REGIONS_EW) ! KMYMS - This PEs spectral zonal wavenumbers ! KASM0 - Address in a spectral array of (m, n=m) ! KUMPP - No. of wave numbers each wave set is responsible for ! KPOSSP - Defines partitioning of global spectral fields among PEs ! KPTRMS - Pointer to the first wave number of a given a-set ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KSMAX - spectral truncation ! KNVALUE - n value for each KSPEC2 spectral coeffient ! GRIDPOINT SPACE ! KFRSTLAT - First latitude of each a-set in grid-point space ! KLSTTLAT - Last latitude of each a-set in grid-point space ! KFRSTLOFF - Offset for first lat of own a-set in grid-point space ! KPTRLAT - Pointer to the start of each latitude ! KPTRFRSTLAT - Pointer to the first latitude of each a-set in ! NSTA and NONL arrays ! KPTRLSTLAT - Pointer to the last latitude of each a-set in ! NSTA and NONL arrays ! KPTRFLOFF - Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 ! KSTA - Position of first grid column for the latitudes on a ! processor. The information is available for all processors. ! The b-sets are distinguished by the last dimension of ! nsta().The latitude band for each a-set is addressed by ! nptrfrstlat(jaset),nptrlstlat(jaset), and ! nptrfloff=nptrfrstlat(myseta) on this processors a-set. ! Each split latitude has two entries in nsta(,:) which ! necessitates the rather complex addressing of nsta(,:) ! and the overdimensioning of nsta by N_REGIONS_NS. ! KONL - Number of grid columns for the latitudes on a processor. ! Similar to nsta() in data structure. ! LDSPLITLAT - TRUE if latitude is split in grid point space over ! two a-sets ! FOURIER SPACE ! KULTPP - number of latitudes for which each a-set is calculating ! the FFT's. ! KPTRLS - pointer to first global latitude of each a-set for which ! it performs the Fourier calculations ! KNMENG - associated (with NLOENG) cut-off zonal wavenumber ! LEGENDRE ! PMU - sin(Gaussian latitudes) ! PGW - Gaussian weights ! PRPNM - Legendre polynomials ! KLEI3 - First dimension of Legendre polynomials ! KSPOLEGL - Second dimension of Legendre polynomials ! KPMS - Adress for legendre polynomial for given M (NSMAX) ! PLAPIN - Eigen-values of the inverse Laplace operator ! KDGLU - Number of active points in an hemisphere for a given wavenumber "m" ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M. Hortal : 2001-03-05 Dimensions of the Legendre polynomials ! R. El Khatib 08-Aug-2012 KSMAX,PLAPIN,KNVALUE,LDLAM,KDEF_RESOL ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD !ifndef INTERFACE USE TPM_GEN ,ONLY : NDEF_RESOL USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRNS, NPRTRW, MYSETV, MYSETW, NPRTRV USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F USE TPM_FLT ,ONLY : S USE SET_RESOL_MOD ,ONLY : SET_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE EQ_REGIONS_MOD ,ONLY : MY_REGION_EW, MY_REGION_NS, & & N_REGIONS_EW, N_REGIONS_NS !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2MX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNUMP INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOT INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTG INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTMX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTL(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KFRSTLOFF INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRFLOFF INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KASM0(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KUMPP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPOSSP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KALLMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDIM0G(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KLSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSTA(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KONL(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW LOGICAL ,OPTIONAL, INTENT(OUT) :: LDSPLITLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KULTPP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNMENG(:) REAL(KIND=JPRD) ,OPTIONAL, INTENT(OUT) :: PMU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGW(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PRPNM(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KLEI3 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPOLEGL INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPMS(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDGLU(0:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PLAPIN(-1:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM !ifndef INTERFACE INTEGER(KIND=JPIM) :: IU1,IU2 INTEGER(KIND=JPIM) :: IC, JN, JMLOC INTEGER(KIND=JPIM) :: IPRTRV,JSETV,IMLOC,IM,ISL,IA,ILA,IS,ILS,IDGLU,J,I ! ------------------------------------------------------------------ ! Set current resolution CALL SET_RESOL(KRESOL) IF(PRESENT(KSPEC)) KSPEC = D%NSPEC IF(PRESENT(KSPEC2)) KSPEC2 = D%NSPEC2 IF(PRESENT(KSPEC2G)) KSPEC2G = R%NSPEC2_G IF(PRESENT(KSPEC2MX)) KSPEC2MX = D%NSPEC2MX IF(PRESENT(KNUMP)) KNUMP = D%NUMP IF(PRESENT(KGPTOT)) KGPTOT = D%NGPTOT IF(PRESENT(KGPTOTG)) KGPTOTG = D%NGPTOTG IF(PRESENT(KGPTOTMX)) KGPTOTMX = D%NGPTOTMX IF(PRESENT(KFRSTLOFF)) KFRSTLOFF = D%NFRSTLOFF IF(PRESENT(KPTRFLOFF)) KPTRFLOFF = D%NPTRFLOFF IF(PRESENT(KPTRFLOFF)) KPTRFLOFF = D%NPTRFLOFF IF(PRESENT(KPRTRW)) KPRTRW = NPRTRW IF(PRESENT(KMYSETW)) KMYSETW = MYSETW IF(PRESENT(KMYSETV)) KMYSETV = MYSETV IF(PRESENT(KMY_REGION_NS)) KMY_REGION_NS = MY_REGION_NS IF(PRESENT(KMY_REGION_EW)) KMY_REGION_EW = MY_REGION_EW IF(PRESENT(LDLAM)) LDLAM = G%LAM IF(PRESENT(KDEF_RESOL)) KDEF_RESOL = NDEF_RESOL IF(PRESENT(KGPTOTL)) THEN IF(UBOUND(KGPTOTL,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KGPTOTL DIM 1 TOO SMALL') ELSEIF(UBOUND(KGPTOTL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('TRANS_INQ: KGPTOTL DIM 2 TOO SMALL') ELSE KGPTOTL(1:N_REGIONS_NS,1:N_REGIONS_EW) = D%NGPTOTL(:,:) ENDIF ENDIF IF(PRESENT(KMYMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KMYMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KMYMS,1) < D%NUMP) THEN CALL ABORT_TRANS('TRANS_INQ: KMYMS TOO SMALL') ELSE KMYMS(1:D%NUMP) = D%MYMS(:) ENDIF ENDIF IF(PRESENT(KASM0)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KASM0 REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KASM0,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KASM0 TOO SMALL') ELSE KASM0(0:R%NSMAX) = D%NASM0(:) ENDIF ENDIF IF(PRESENT(KUMPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KUMPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KUMPP,1) < NPRTRW) THEN CALL ABORT_TRANS('TRANS_INQ: KUMPP TOO SMALL') ELSE KUMPP(1:NPRTRW) = D%NUMPP(:) ENDIF ENDIF IF(PRESENT(KPOSSP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPOSSP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPOSSP,1) < NPRTRW+1) THEN CALL ABORT_TRANS('TRANS_INQ: KPOSSP TOO SMALL') ELSE KPOSSP(1:NPRTRW+1) = D%NPOSSP(:) ENDIF ENDIF IF(PRESENT(KPTRMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRMS,1) < NPRTRW) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRMS TOO SMALL') ELSE KPTRMS(1:NPRTRW) = D%NPTRMS(:) ENDIF ENDIF IF(PRESENT(KALLMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KALLMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KALLMS,1) < R%NSMAX+1) THEN CALL ABORT_TRANS('TRANS_INQ: KALLMS TOO SMALL') ELSE KALLMS(1:R%NSMAX+1) = D%NALLMS(:) ENDIF ENDIF IF(PRESENT(KDIM0G)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KDIM0G REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KDIM0G,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KDIM0G TOO SMALL') ELSE KDIM0G(0:R%NSMAX) = D%NDIM0G(0:R%NSMAX) ENDIF ENDIF IF(PRESENT(KFRSTLAT)) THEN IF(UBOUND(KFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KFRSTLAT TOO SMALL') ELSE KFRSTLAT(1:N_REGIONS_NS) = D%NFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KLSTLAT)) THEN IF(UBOUND(KLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KLSTLAT TOO SMALL') ELSE KLSTLAT(1:N_REGIONS_NS) = D%NLSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLAT)) THEN IF(UBOUND(KPTRLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLAT TOO SMALL') ELSE KPTRLAT(1:R%NDGL) = D%NPTRLAT(:) ENDIF ENDIF IF(PRESENT(KPTRFRSTLAT)) THEN IF(UBOUND(KPTRFRSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRFRSTLAT TOO SMALL') ELSE KPTRFRSTLAT(1:N_REGIONS_NS) = D%NPTRFRSTLAT(:) ENDIF ENDIF IF(PRESENT(KPTRLSTLAT)) THEN IF(UBOUND(KPTRLSTLAT,1) < N_REGIONS_NS) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLSTLAT TOO SMALL') ELSE KPTRLSTLAT(1:N_REGIONS_NS) = D%NPTRLSTLAT(:) ENDIF ENDIF IF(PRESENT(KSTA)) THEN IF(UBOUND(KSTA,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('TRANS_INQ: KSTA DIM 1 TOO SMALL') ELSEIF(UBOUND(KSTA,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('TRANS_INQ: KSTA DIM 2 TOO SMALL') ELSE KSTA(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NSTA(:,:) ENDIF ENDIF IF(PRESENT(KONL)) THEN IF(UBOUND(KONL,1) < R%NDGL+N_REGIONS_NS-1) THEN CALL ABORT_TRANS('TRANS_INQ: KONL DIM 1 TOO SMALL') ELSEIF(UBOUND(KONL,2) < N_REGIONS_EW) THEN CALL ABORT_TRANS('TRANS_INQ: KONL DIM 2 TOO SMALL') ELSE KONL(1:R%NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) = D%NONL(:,:) ENDIF ENDIF IF(PRESENT(LDSPLITLAT)) THEN IF(UBOUND(LDSPLITLAT,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: LDSPLITLAT TOO SMALL') ELSE LDSPLITLAT(1:R%NDGL) = D%LSPLITLAT(:) ENDIF ENDIF IF(PRESENT(KULTPP)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KULTPP REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KULTPP,1) < NPRTRNS) THEN CALL ABORT_TRANS('TRANS_INQ: KULTPP TOO SMALL') ELSE KULTPP(1:NPRTRNS) = D%NULTPP(:) ENDIF ENDIF IF(PRESENT(KPTRLS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPTRLS,1) < NPRTRNS) THEN CALL ABORT_TRANS('TRANS_INQ: KPTRLS TOO SMALL') ELSE KPTRLS(1:NPRTRNS) = D%NPTRLS(:) ENDIF ENDIF IF(PRESENT(KNMENG)) THEN IF(UBOUND(KNMENG,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: KNMENG TOO SMALL') ELSE KNMENG(1:R%NDGL) = G%NMEN(1:R%NDGL) ENDIF ENDIF IF(PRESENT(PMU)) THEN IF(UBOUND(PMU,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: PMU TOO SMALL') ELSE PMU(1:R%NDGL) = F%RMU ENDIF ENDIF IF(PRESENT(PGW)) THEN IF(UBOUND(PGW,1) < R%NDGL) THEN CALL ABORT_TRANS('TRANS_INQ: PGW TOO SMALL') ELSE PGW(1:R%NDGL) = REAL(F%RW,JPRB) ENDIF ENDIF IF(PRESENT(PRPNM)) THEN IF( .NOT. S%LKEEPRPNM .AND. S%LUSEFLT) THEN CALL ABORT_TRANS('TRANS_INQ: PRPNM REQUIRED BUT POLYS. HAVE NOT BEEN KEPT') ENDIF IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: PRPNM REQUIRED BUT LGRIDONLY=T') ENDIF IU1 = UBOUND(PRPNM,1) IU2 = UBOUND(PRPNM,2) IF(IU1 < R%NDGNH) THEN CALL ABORT_TRANS('TRANS_INQ:FIRST DIM. OF PRNM TOO SMALL') ELSE ! IU1 = MIN(IU1,R%NLEI3) ! IU2 = MIN(IU2,D%NSPOLEGL) ! PRPNM(1:IU1,1:IU2) = F%RPNM(1:IU1,1:IU2) DO JMLOC=1,D%NUMP,NPRTRV IPRTRV=MIN(NPRTRV,D%NUMP-JMLOC+1) DO JSETV=1,IPRTRV IMLOC=JMLOC+JSETV-1 IM = D%MYMS(IMLOC) ISL = MAX(R%NDGNH-G%NDGLU(IM)+1,1) IA = 1+MOD(R%NSMAX-IM+2,2) ILA = (R%NSMAX-IM+2)/2 IS = 1+MOD(R%NSMAX-IM+1,2) ILS = (R%NSMAX-IM+3)/2 IDGLU = MIN(R%NDGNH,G%NDGLU(IM)) DO J=1,ILA DO I=1,IDGLU PRPNM(ISL+I-1,D%NPMS(IM)+IA+(J-1)*2) = S%FA(IMLOC)%RPNMA(I,J) ENDDO ENDDO DO J=1,ILS DO I=1,IDGLU PRPNM(ISL+I-1,D%NPMS(IM)+IS+(J-1)*2) = S%FA(IMLOC)%RPNMS(I,J) ENDDO ENDDO ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KLEI3)) THEN KLEI3=R%NLEI3 ENDIF IF(PRESENT(KSPOLEGL)) THEN KSPOLEGL=D%NSPOLEGL ENDIF IF(PRESENT(KPMS)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KPMS REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(KPMS,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KPMS TOO SMALL') ELSE KPMS(0:R%NSMAX) = D%NPMS(0:R%NSMAX) ENDIF ENDIF IF(PRESENT(KSMAX)) KSMAX = R%NSMAX IF(PRESENT(PLAPIN)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: PLAPIN REQUIRED BUT LGRIDONLY=T') ENDIF IF(UBOUND(PLAPIN,1) < R%NSMAX+2) THEN CALL ABORT_TRANS('TRANS_INQ: PLAPIN TOO SMALL') ELSEIF (LBOUND(PLAPIN,1) /= -1) THEN CALL ABORT_TRANS('TRANS_INQ: LOWER BOUND OF PLAPIN SHOULD BE -1') ELSE PLAPIN(-1:R%NSMAX+2) = F%RLAPIN(:) ENDIF ENDIF IF(PRESENT(KNVALUE)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_INQ: KNVALUE REQUIRED BUT LGRIDONLY=T') ENDIF IF(SIZE(KNVALUE) < D%NSPEC2) THEN CALL ABORT_TRANS('TRANS_INQ: KNVALUE TOO SMALL') ELSE IC=1 DO JMLOC=1,D%NUMP DO JN=D%MYMS(JMLOC),R%NSMAX KNVALUE(IC )=JN KNVALUE(IC+1)=JN IC=IC+2 ENDDO ENDDO ENDIF ENDIF IF(PRESENT(KDGLU)) THEN IF(UBOUND(KDGLU,1) < R%NSMAX) THEN CALL ABORT_TRANS('TRANS_INQ: KDGLU TOO SMALL') ELSE KDGLU(0:R%NSMAX) = G%NDGLU(0:R%NSMAX) ENDIF ENDIF ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE TRANS_INQ ectrans-1.8.0/src/trans/cpu/external/gpnorm_transtl.F900000664000175000017500000000477315174631767023257 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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 GPNORM_TRANSTL(PGP,KFIELDS,KPROMA,PAVE,KRESOL) !**** *GPNORM_TRANSTL* - calculate grid-point norms ! reduced version for linear model ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL GPNORM_TRANSTL(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! Filip Vana, (c) ECMWF ! 9-Sep-2024 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F USE SET_RESOL_MOD ,ONLY : SET_RESOL USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE GPNORM_TRANS_CTLTL_MOD, ONLY : GPNORM_TRANS_CTLTL !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSTL',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) CALL GPNORM_TRANS_CTLTL(PGP,KFIELDS,KPROMA,PAVE,F%RW(1:R%NDGL)) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSTL',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANSTL ectrans-1.8.0/src/trans/cpu/external/gath_spec.F900000664000175000017500000001412615174631767022134 0ustar alastairalastair! (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 GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LDZA0IP) !**** *GATH_SPEC* - Gather global spectral array from processors ! Purpose. ! -------- ! Interface routine for gathering spectral array !** Interface. ! ---------- ! CALL GATH_SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for gathering each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PSPEC(:,:) - Local spectral array ! LDZA0IP - Set to zero imaginary part of first coefficients ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! Modified 03-09-30 Y. Seity, bug correction IFSEND=0 ! Modified 13-10-10 P. Marguinaud add LDZA0IP option ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC USE SET_RESOL_MOD ,ONLY : SET_RESOL USE GATH_SPEC_CONTROL_MOD ,ONLY : GATH_SPEC_CONTROL USE SUWAVEDI_MOD ,ONLY : SUWAVEDI 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) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFGATHG) INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J INTEGER(KIND=JPIM) :: IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G, ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GATH_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) LLDIM1_IS_FLD = .TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD = 1 ICOEFF = 2 ELSE IFLD = 2 ICOEFF = 1 ENDIF IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_SPEC: KTO TOO SHORT!') ENDIF ISMAX = R%NSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX ALLOCATE(IDIM0G(0:ISMAX)) ALLOCATE(IALLMS(ISMAX+1)) ALLOCATE(IKN(0:ISMAX)) IF(ISMAX /= R%NSMAX) THEN CALL SUWAVEDI(ISMAX,ISMAX,NPRTRW,MYSETW,KPOSSP=IPOSSP,KSPEC2=ISPEC2,& & KUMPP=IUMPP,KALLMS=IALLMS,KPTRMS=IPTRMS,KSPEC2MX=ISPEC2MX, & & KDIM0G=IDIM0G) ISPEC2_G = (ISMAX+1)*(ISMAX+2) ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ISPEC2MX = D%NSPEC2MX IUMPP(:) = D%NUMPP(:) IALLMS(:) = D%NALLMS(:) IPTRMS(:) = D%NPTRMS(:) ENDIF DO J=0,ISMAX IKN(J)=2*(ISMAX+1-J) ENDDO IFSEND = 0 IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_SPEC:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_SPEC:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('GATH_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFRECV) THEN WRITE(NERR,*) 'GATH_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFRECV CALL ABORT_TRANS('GATH_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'GATH_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('GATH_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFGATHG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'GATH_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('GATH_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFSEND = IFSEND+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFGATHG) ELSEIF(NPRTRV > 1) THEN WRITE(NERR,*) 'GATH_SPEC:KVSET MISSING, NPRTRV ',NPRTRV CALL ABORT_TRANS('GATH_SPEC:KVSET MISSING, NPRTRV > 1') ELSE IFSEND = KFGATHG IVSET(:) = 1 ENDIF IF(IFSEND > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('GATH_SPEC: FIELDS TO RECIEVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFSEND) THEN CALL ABORT_TRANS('GATH_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('GATH_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,& & ISMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,LDZA0IP) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('GATH_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE GATH_SPEC ectrans-1.8.0/src/trans/cpu/external/gpnorm_transad.F900000664000175000017500000000475515174631767023224 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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 GPNORM_TRANSAD(PGP,KFIELDS,KPROMA,PAVE,KRESOL) !**** *GPNORM_TRANSAD* - calculate grid-point norms ! (adjoint version) ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL GPNORM_TRANSAD(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! Filip Vana ! (c) ECMWF 14-Aug-2024 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F USE SET_RESOL_MOD ,ONLY : SET_RESOL USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE GPNORM_TRANS_CTLAD_MOD, ONLY : GPNORM_TRANS_CTLAD !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSAD',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) CALL GPNORM_TRANS_CTLAD(PGP,KFIELDS,KPROMA,PAVE,F%RW(1:R%NDGL)) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANSAD',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANSAD ectrans-1.8.0/src/trans/cpu/external/dist_grid_32.F900000664000175000017500000000775715174631767022467 0ustar alastairalastair! (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 DIST_GRID_32(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP) !**** *DIST_GRID_32* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID_32(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_GRID_32_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRM ,JPRB !ifndef INTERFACE USE TPM_GEN, ONLY : NERR, NOUT USE TPM_DISTR, ONLY : D, NPROC, MYPROC USE SET_RESOL_MOD, ONLY : SET_RESOL USE DIST_GRID_32_CTL_MOD, ONLY : DIST_GRID_32_CTL USE ABORT_TRANS_MOD, ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRM) , INTENT(OUT) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIST_GRID_32',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_GRID_32: KFROM TOO SHORT!') ENDIF IFSEND = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'DIST_GRID_32:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('DIST_GRID_32:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'DIST_GRID_32:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('DIST_GRID_32:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFDISTG) THEN WRITE(NOUT,*)'DIST_GRID_32:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFDISTG CALL ABORT_TRANS('DIST_GRID_32:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'DIST_GRID_32:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('DIST_GRID_32:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('DIST_GRID_32:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('DIST_GRID_32:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFSEND) THEN CALL ABORT_TRANS('DIST_GRID_32:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL DIST_GRID_32_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP) IF (LHOOK) CALL DR_HOOK('DIST_GRID_32',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID_32 ectrans-1.8.0/src/trans/cpu/external/setup_trans.F900000664000175000017500000003403615174631767022550 0ustar alastairalastair! (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 SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& &KTMAX,KRESOL,PWEIGHT,LDGRIDONLY,LDUSERPNM,LDKEEPRPNM,LDUSEFLT,& &LDSPSETUPONLY,LDPNMONLY,LDUSEFFTW,LD_ALL_FFTW,& &LDLL,LDSHIFTLL,CDIO_LEGPOL,CDLEGPOLFNAME,KLEGPOLPTR,KLEGPOLPTR_LEN) !**** *SETUP_TRANS* - Setup transform package for specific resolution ! Purpose. ! -------- ! To setup for making spectral transforms. Each call to this routine ! creates a new resolution up to a maximum of NMAX_RESOL set up in ! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can ! be called. !** Interface. ! ---------- ! CALL SETUP_TRANS(...) ! Explicit arguments : KLOEN,LDSPLIT are optional arguments ! -------------------- ! KSMAX - spectral truncation required ! KDGL - number of Gaussian latitudes ! KDLON - number of points on each Gaussian latitude [2*KDGL] ! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] ! LDSPLIT - true if split latitudes in grid-point space [false] ! KTMAX - truncation order for tendencies? ! KRESOL - the resolution identifier ! PWEIGHT - the weight per grid-point (for a weighted distribution); ! Note, only seems to be used from within enkf ! LDGRIDONLY - true if only grid space is required ! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution ! in spectral and grid-point space ! LDSPLIT describe the distribution among processors of grid-point data and ! has no relevance if you are using a single processor ! PSTRET - stretching factor - for the case the Legendre polynomials are ! computed on the stretched sphere - works with LSOUTHPNM ! LDUSEFLT - use Fast Legandre Transform (Butterfly algorithm) ! LDUSERPNM - Use Belusov algorithm to compute legendre pol. (else new alg.) ! LDKEEPRPNM - Keep Legendre Polynomials (only applicable when using ! FLT, otherwise always kept) ! LDPNMONLY - Compute the Legendre polynomials only, not the FFTs. ! LDUSEFFTW - Use FFTW for FFTs (option deprecated - FFTW is now mandatory) ! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another ! LDLL - Setup second set of input/output latitudes ! the number of input/output latitudes to transform is equal KDGL ! or KDGL+2 in the case that includes poles + equator ! the number of input/output longitudes to transform is 2*KDGL ! LDSHIFTLL - Shift output lon/lat data by 0.5*dx and 0.5*dy ! CDIO_LEGPOL - IO option on Legendre polinomials : N.B. Only works for NPROC=1 ! Options: ! 'READF' - read Leg.Pol. from file CDLEGPOLFNAME ! 'WRITEF' - write Leg.Pol. to file CDLEGPOLFNAME ! 'MEMBUF' - Leg. Pol provided in shared memory segment pointed to by KLEGPOLPTR of ! length KLEGPOLPTR_LEN ! CDLEGPOLFNAME - file name for Leg.Pol. IO ! KLEGPOLPTR - pointer to Legendre polynomials memory segment ! KLEGPOLPTR_LEN - length of Legendre polynomials memory segment ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- SETUP_DIMS - setup distribution independent dimensions ! SUMP_TRANS_PRELEG - first part of setup of distr. environment ! SULEG - Compute Legandre polonomial and Gaussian ! Latitudes and Weights ! SUMP_TRANS - Second part of setup of distributed environment ! SHAREDMEM_CREATE - create memory buffer for Leg.pol. ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! Daan Degrauwe : Mar 2012 E'-zone dimensions ! R. El Khatib 09-Aug-2012 %LAM in GEOM_TYPE ! R. El Khatib 14-Jun-2013 PSTRET, LDPNMONLY, LENABLED ! G. Mozdzynski : Oct 2014 Support f ! N. Wedi : Apr 2015 Support dual set of lat/lon ! G. Mozdzynski : Jun 2015 Support alternative FFTs to FFTW ! M.Hamrud/W.Deconinck : July 2015 IO options for Legenndre polynomials ! R. El Khatib 07-Mar-2016 Better flexibility for Legendre polynomials computation in stretched mode ! R. El Khatib 08-Jun-2023 LALL_FFTW for better flexibility ! ------------------------------------------------------------------ USE PARKIND1, ONLY: JPIM, JPRD, JPRB ! only use of JPRB is for diagnostic print of backend precision USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT,C_ASSOCIATED,C_SIZE_T !ifndef INTERFACE USE TPM_GEN ,ONLY : NOUT, MSETUP0, NCUR_RESOL, NDEF_RESOL, & & NMAX_RESOL, NPRINTLEV, LENABLED, NERR USE TPM_DIM ,ONLY : R, DIM_RESOL USE TPM_DISTR ,ONLY : D, DISTR_RESOL,NPROC USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : FIELDS_RESOL USE TPM_FFTW ,ONLY : TW, FFTW_RESOL, INIT_PLANS_FFTW USE TPM_FLT ,ONLY : S, FLT_RESOL USE TPM_CTL ,ONLY : C, CTL_RESOL USE SET_RESOL_MOD ,ONLY : SET_RESOL USE SETUP_DIMS_MOD ,ONLY : SETUP_DIMS USE SUMP_TRANS_MOD ,ONLY : SUMP_TRANS USE SUMP_TRANS_PRELEG_MOD ,ONLY : SUMP_TRANS_PRELEG USE SULEG_MOD ,ONLY : SULEG USE PRE_SULEG_MOD ,ONLY : PRE_SULEG USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE SHAREDMEM_MOD ,ONLY : SHAREDMEM_CREATE USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM) ,INTENT(IN) :: KSMAX,KDGL INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KDLON INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KLOEN(:) LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KTMAX INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT):: KRESOL REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PSTRET LOGICAL ,OPTIONAL,INTENT(IN):: LDGRIDONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFLT LOGICAL ,OPTIONAL,INTENT(IN):: LD_ALL_FFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDUSERPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDKEEPRPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDSPSETUPONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDPNMONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDLL LOGICAL ,OPTIONAL,INTENT(IN):: LDSHIFTLL CHARACTER(LEN=*),OPTIONAL,INTENT(IN):: CDIO_LEGPOL CHARACTER(LEN=*),OPTIONAL,INTENT(IN):: CDLEGPOLFNAME TYPE(C_PTR) ,OPTIONAL,INTENT(IN) :: KLEGPOLPTR INTEGER(C_SIZE_T) ,OPTIONAL,INTENT(IN) :: KLEGPOLPTR_LEN !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: JGL,JRES,IDEF_RESOL LOGICAL :: LLP1,LLP2, LLSPSETUPONLY REAL(KIND=JPHOOK) :: ZHOOK_HANDLE #include "user_clock.intfb.h" ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SETUP_TRANS',0,ZHOOK_HANDLE) IF(MSETUP0 == 0) THEN CALL ABORT_TRANS('SETUP_TRANS: SETUP_TRANS0 HAS TO BE CALLED BEFORE SETUP_TRANS') ENDIF LLP1 = NPRINTLEV>0 LLP2 = NPRINTLEV>1 IF(LLP1) WRITE(NOUT,*) '=== ENTER ROUTINE SETUP_TRANS ===' IF(LLP1) THEN IF (JPRB == JPRD) THEN WRITE(NOUT,'(A)') "CPU double precision version" ELSE WRITE(NOUT,'(A)') "CPU single precision version" ENDIF WRITE(NOUT,'(A)') ENDIF ! Allocate resolution dependent structures IF(.NOT. ALLOCATED(DIM_RESOL)) THEN IDEF_RESOL = 1 ALLOCATE(DIM_RESOL(NMAX_RESOL)) ALLOCATE(FIELDS_RESOL(NMAX_RESOL)) ALLOCATE(GEOM_RESOL(NMAX_RESOL)) ALLOCATE(DISTR_RESOL(NMAX_RESOL)) ALLOCATE(FFTW_RESOL(NMAX_RESOL)) ALLOCATE(FLT_RESOL(NMAX_RESOL)) ALLOCATE(CTL_RESOL(NMAX_RESOL)) GEOM_RESOL(:)%LAM=.FALSE. ALLOCATE(LENABLED(NMAX_RESOL)) LENABLED(:)=.FALSE. ELSE IDEF_RESOL = NMAX_RESOL+1 DO JRES=1,NMAX_RESOL IF(.NOT.LENABLED(JRES)) THEN IDEF_RESOL = JRES EXIT ENDIF ENDDO IF(IDEF_RESOL > NMAX_RESOL) THEN CALL ABORT_TRANS('SETUP_TRANS:IDEF_RESOL > NMAX_RESOL') ENDIF ENDIF IF (PRESENT(KRESOL)) THEN KRESOL=IDEF_RESOL ENDIF ! Point at structures due to be initialized CALL SET_RESOL(IDEF_RESOL,LDSETUP=.TRUE.) IF(LLP1) WRITE(NOUT,*) '=== DEFINING RESOLUTION ',NCUR_RESOL ! Defaults for optional arguments G%LREDUCED_GRID = .FALSE. G%RSTRET=1.0_JPRD D%LGRIDONLY = .FALSE. D%LSPLIT = .FALSE. D%LCPNMONLY=.FALSE. S%LUSE_BELUSOV=.TRUE. ! use Belusov algorithm to compute RPNM array instead of per m S%LKEEPRPNM=.FALSE. ! Keep Legendre polonomials (RPNM) S%LUSEFLT=.FALSE. ! Use fast legendre transforms TW%LALL_FFTW=.FALSE. ! transform fields one at a time LLSPSETUPONLY = .FALSE. ! Only create distributed spectral setup S%LDLL = .FALSE. ! use mapping to/from second set of latitudes S%LSHIFTLL = .FALSE. ! shift output lat-lon by 0.5dx, 0.5dy C%LREAD_LEGPOL = .FALSE. C%LWRITE_LEGPOL = .FALSE. ! NON-OPTIONAL ARGUMENTS R%NSMAX = KSMAX R%NDGL = KDGL ! E'-defaults R%NNOEXTZL=0 R%NNOEXTZG=0 ! IMPLICIT argument : G%LAM = .FALSE. IF(PRESENT(KDLON)) THEN R%NDLON = KDLON ELSE R%NDLON = 2*R%NDGL ENDIF IF(PRESENT(LDLL)) THEN S%LDLL=LDLL IF( LDLL ) THEN S%NDLON=R%NDLON ! account for pole + equator R%NDGL=R%NDGL+2 IF(PRESENT(LDSHIFTLL)) THEN S%LSHIFTLL = LDSHIFTLL ! geophysical (shifted) lat-lon without pole and equator IF(S%LSHIFTLL) R%NDGL=R%NDGL-2 ENDIF S%NDGL=R%NDGL ENDIF ENDIF IF (R%NDGL <= 0 .OR. MOD(R%NDGL,2) /= 0) THEN CALL ABORT_TRANS ('SETUP_TRANS: KDGL IS NOT A POSITIVE, EVEN NUMBER') ENDIF ! Optional arguments ALLOCATE(G%NLOEN(R%NDGL)) IF(LLP2)WRITE(NOUT,9) 'NLOEN ',SIZE(G%NLOEN ),SHAPE(G%NLOEN ) IF(PRESENT(KLOEN)) THEN IF( MINVAL(KLOEN(:)) <= 0 )THEN CALL ABORT_TRANS ('SETUP_TRANS: KLOEN INVALID (ONE or MORE POINTS <= 0)') ENDIF R%NDLON=MAXVAL(KLOEN(:)) DO JGL=1,R%NDGL IF(KLOEN(JGL) /= R%NDLON) THEN G%LREDUCED_GRID = .TRUE. EXIT ENDIF ENDDO ENDIF IF (G%LREDUCED_GRID) THEN G%NLOEN(:) = KLOEN(1:R%NDGL) ELSE G%NLOEN(:) = R%NDLON ENDIF IF(PRESENT(LDSPLIT)) THEN D%LSPLIT = LDSPLIT ENDIF IF(PRESENT(KTMAX)) THEN R%NTMAX = KTMAX ELSE R%NTMAX = R%NSMAX ENDIF IF(PRESENT(PWEIGHT)) THEN D%LWEIGHTED_DISTR = .TRUE. IF( D%LWEIGHTED_DISTR .AND. .NOT.D%LSPLIT )THEN CALL ABORT_TRANS('SETUP_TRANS: LWEIGHTED_DISTR=T AND LSPLIT=F NOT SUPPORTED') ENDIF IF(SIZE(PWEIGHT) /= SUM(G%NLOEN(:)) )THEN CALL ABORT_TRANS('SETUP_TRANS:SIZE(PWEIGHT) /= SUM(G%NLOEN(:))') ENDIF IF( MINVAL(PWEIGHT(:)) < 0.0_JPRD )THEN CALL ABORT_TRANS('SETUP_TRANS: INVALID WEIGHTS') ENDIF ALLOCATE(D%RWEIGHT(SIZE(PWEIGHT))) D%RWEIGHT(:)=PWEIGHT(:) ELSE D%LWEIGHTED_DISTR = .FALSE. ENDIF IF(PRESENT(LDGRIDONLY)) THEN D%LGRIDONLY=LDGRIDONLY ENDIF IF(PRESENT(LDSPSETUPONLY)) THEN LLSPSETUPONLY=LDSPSETUPONLY ENDIF IF(PRESENT(LDPNMONLY)) THEN D%LCPNMONLY=LDPNMONLY ENDIF IF(PRESENT(LDUSEFFTW)) THEN WRITE(NOUT,*) 'LDUSEFFTW option provided to SETUP_TRANS' WRITE(NOUT,*) 'FFTW is now mandatory so this option is deprecated' ENDIF ! Setup distribution independent dimensions CALL SETUP_DIMS IF(PRESENT(LD_ALL_FFTW)) THEN TW%LALL_FFTW=LD_ALL_FFTW ENDIF S%LSOUTHPNM=.FALSE. IF(PRESENT(PSTRET)) THEN IF (ABS(PSTRET-1.0_JPRD)>100._JPRD*EPSILON(1._JPRD)) THEN G%RSTRET=PSTRET S%LSOUTHPNM=.TRUE. R%NLEI3=2*R%NLEI3 ! double ENDIF ENDIF IF(PRESENT(CDIO_LEGPOL)) THEN IF(NPROC > 1) CALL ABORT_TRANS('SETUP_TRANS:CDIO_LEGPOL OPTIONS ONLY FOR NPROC=1 ') IF(R%NSMAX > 511 ) S%LUSEFLT = .TRUE. !To save IO and memory IF(TRIM(CDIO_LEGPOL) == 'readf' .OR. TRIM(CDIO_LEGPOL) == 'READF' ) THEN IF(.NOT.PRESENT(CDLEGPOLFNAME)) CALL ABORT_TRANS('SETUP_TRANS: CDLEGPOLFNAME ARGUMENT MISSING') C%LREAD_LEGPOL = .TRUE. C%CLEGPOLFNAME = TRIM(CDLEGPOLFNAME) C%CIO_TYPE='file' ELSEIF(TRIM(CDIO_LEGPOL) == 'writef' .OR. TRIM(CDIO_LEGPOL) == 'WRITEF') THEN IF(.NOT.PRESENT(CDLEGPOLFNAME)) CALL ABORT_TRANS('SETUP_TRANS: CDLEGPOLFNAME ARGUMENT MISSING') C%LWRITE_LEGPOL = .TRUE. C%CLEGPOLFNAME = TRIM(CDLEGPOLFNAME) C%CIO_TYPE='file' ELSEIF(TRIM(CDIO_LEGPOL) == 'membuf' .OR. TRIM(CDIO_LEGPOL) == 'MEMBUF') THEN IF(.NOT.PRESENT(KLEGPOLPTR)) CALL ABORT_TRANS('SETUP_TRANS: KLEGPOLPTR ARGUMENT MISSING') IF(.NOT.C_ASSOCIATED(KLEGPOLPTR)) CALL ABORT_TRANS('SETUP_TRANS: KLEGPOLPTR NULL POINTER') IF(.NOT.PRESENT(KLEGPOLPTR_LEN)) CALL ABORT_TRANS('SETUP_TRANS: KLEGPOLPTR_LEN ARGUMENT MISSING') C%LREAD_LEGPOL = .TRUE. C%CIO_TYPE='mbuf' CALL SHAREDMEM_CREATE( C%STORAGE,KLEGPOLPTR,KLEGPOLPTR_LEN) ELSE WRITE(NERR,*) 'CDIO_LEGPOL ', TRIM(CDIO_LEGPOL) CALL ABORT_TRANS('SETUP_TRANS:CDIO_LEGPOL UNKNOWN METHOD ') ENDIF ENDIF IF(PRESENT(LDUSEFLT)) THEN S%LUSEFLT=LDUSEFLT ENDIF IF(PRESENT(LDUSERPNM)) THEN S%LUSE_BELUSOV=LDUSERPNM ENDIF IF(PRESENT(LDKEEPRPNM)) THEN IF(S%LUSEFLT) THEN IF(LDKEEPRPNM.AND..NOT.LDUSERPNM) THEN CALL ABORT_TRANS('SETUP_TRANS: LDKEEPRPNM=true with LDUSERPNM=false') ENDIF ENDIF S%LKEEPRPNM=LDKEEPRPNM ENDIF ! Setup resolution dependent structures ! ------------------------------------- ! First part of setup of distributed environment CALL SUMP_TRANS_PRELEG IF( .NOT.LLSPSETUPONLY ) THEN ! Compute Legendre polonomial and Gaussian Latitudes and Weights CALL SULEG ! Second part of setup of distributed environment CALL SUMP_TRANS CALL GSTATS(1802,0) ! Initialize Fast Fourier Transform package IF (.NOT. D%LCPNMONLY .AND. .NOT. D%LGRIDONLY) THEN CALL INIT_PLANS_FFTW(R%NDLON) ENDIF CALL GSTATS(1802,1) ELSE CALL PRE_SULEG ENDIF ! Signal the current resolution is active LENABLED(IDEF_RESOL)=.TRUE. NDEF_RESOL = COUNT(LENABLED) IF (LHOOK) CALL DR_HOOK('SETUP_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) !endif INTERFACE END SUBROUTINE SETUP_TRANS ectrans-1.8.0/src/trans/cpu/external/vordiv_to_uv.F900000664000175000017500000001164415174631767022726 0ustar alastairalastair! (C) Copyright 2015- ECMWF. ! (C) Copyright 2015- 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 VORDIV_TO_UV(PSPVOR,PSPDIV,PSPU,PSPV,KSMAX,KVSETUV) !**** *VORDIV_TO_UV* - Convert spectral vorticity and divergence to spectral U (u*cos(theta)) and V (v*cos(theta). ! Purpose. ! -------- ! Interface routine for Convert spectral vorticity and divergence to spectral U and V !** Interface. ! ---------- ! CALL VORDIV_TO_UV(...) ! Explicit arguments : ! -------------------- ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPU(:,:) - spectral U (u*cos(theta) (output) ! PSPV(:,:) - spectral V (v*cos(theta) (output) ! KSMAX - spectral resolution (input) ! KVSETUV(:) - Optionally 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. ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- VD2UV_CTL - control vordiv to uv ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 15-06-15 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, MSETUP0 USE TPM_DISTR ,ONLY : NPRTRV, MYSETV USE SET_RESOL_MOD ,ONLY : SET_RESOL USE VD2UV_CTL_MOD ,ONLY : VD2UV_CTL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB), INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB), INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PSPU(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PSPV(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) !ifndef INTERFACE ! Local variables INTEGER(KIND=JPIM) :: J INTEGER(KIND=JPIM) :: IF_UV,IF_UV_G,IRESOL,IDGL LOGICAL :: LTMP_SETUP0 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE #include "setup_trans0.h" #include "setup_trans.h" #include "trans_release.h" #include "trans_end.h" ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('VORDIV_TO_UV',0,ZHOOK_HANDLE) !CALL GSTATS(XXXX,0) IF(MSETUP0 == 0) THEN CALL SETUP_TRANS0() LTMP_SETUP0 = .TRUE. ELSE LTMP_SETUP0 = .FALSE. ENDIF IDGL = 2 ! It doesn't matter as long as it's a positive even number CALL SETUP_TRANS(KSMAX,IDGL,LDSPSETUPONLY=.TRUE.,KRESOL=IRESOL) CALL SET_RESOL(IRESOL) ! Set defaults IF_UV = 0 IF_UV_G = 0 ! Decide requirements IF(PRESENT(KVSETUV)) THEN IF_UV_G = UBOUND(KVSETUV,1) DO J=1,IF_UV_G IF(KVSETUV(J) > NPRTRV .OR. KVSETUV(J) < 1) THEN WRITE(NERR,*) 'VORDIV_TO_UV:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('VORDIV_TO_UV:KVSETUV TOO LONG OR CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSETUV(J) == MYSETV) THEN IF_UV = IF_UV+1 ENDIF ENDDO ELSE IF_UV = UBOUND(PSPVOR,1) IF_UV_G = IF_UV ENDIF ! Consistency checks IF (IF_UV > 0) THEN IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPVOR TOO SHORT') ENDIF IF(UBOUND(PSPDIV,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPDIV TOO SHORT') ENDIF IF(UBOUND(PSPU,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPU,1) < IF_UV ',UBOUND(PSPU,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPU TOO SHORT') ENDIF IF(UBOUND(PSPV,1) < IF_UV) THEN WRITE(NERR,*)'VORDIV_TO_UV : UBOUND(PSPV,1) < IF_UV ',UBOUND(PSPV,1),IF_UV CALL ABORT_TRANS('VORDIV_TO_UV : PSPV TOO SHORT') ENDIF 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('VORDIV_TO_UV: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF !CALL GSTATS(XXXX,1) ! ------------------------------------------------------------------ ! Perform transform CALL VD2UV_CTL(IF_UV,PSPVOR,PSPDIV,PSPU,PSPV) CALL TRANS_RELEASE(IRESOL) IF (LTMP_SETUP0) THEN CALL TRANS_END() ENDIF IF (LHOOK) CALL DR_HOOK('VORDIV_TO_UV',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE VORDIV_TO_UV ectrans-1.8.0/src/trans/cpu/external/dist_spec.F900000664000175000017500000001416315174631767022155 0ustar alastairalastair! (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 DIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& & LDIM1_IS_FLD,KSMAX,KSORT) !**** *DIST_SPEC* - Distribute global spectral array among processors ! Purpose. ! -------- ! Interface routine for distributing spectral array !** Interface. ! ---------- ! CALL DIST__SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PSPEC(:,:) - Local spectral array ! KSORT (:) - Re-order fields on output ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! P.Marguinaud : 10-10-14 Add KSORT ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYSETW, MYPROC, NPROC USE SET_RESOL_MOD ,ONLY : SET_RESOL USE DIST_SPEC_CONTROL_MOD ,ONLY : DIST_SPEC_CONTROL USE SUWAVEDI_MOD ,ONLY : SUWAVEDI 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(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IVSET(KFDISTG) INTEGER(KIND=JPIM) :: IFSEND,IFRECV,J,IFLD,ICOEFF INTEGER(KIND=JPIM) :: ISMAX, ISPEC2, ISPEC2_G, ISPEC2MX INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1) INTEGER(KIND=JPIM) :: IUMPP(NPRTRW) INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW) INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:) INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:) LOGICAL :: LLDIM1_IS_FLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIST_SPEC',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) LLDIM1_IS_FLD = .TRUE. IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD IF(LLDIM1_IS_FLD) THEN IFLD = 1 ICOEFF = 2 ELSE IFLD = 2 ICOEFF = 1 ENDIF IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_SPEC: KFROM TOO SHORT!') ENDIF ISMAX = R%NSMAX IF(PRESENT(KSMAX)) ISMAX = KSMAX ALLOCATE(IDIM0G(0:ISMAX)) ALLOCATE(IALLMS(ISMAX+1)) ALLOCATE(IKN(0:ISMAX)) IF(ISMAX /= R%NSMAX) THEN CALL SUWAVEDI(ISMAX,ISMAX,NPRTRW,MYSETW,KPOSSP=IPOSSP,KSPEC2=ISPEC2,& & KDIM0G=IDIM0G,KSPEC2MX=ISPEC2MX,KUMPP=IUMPP,KALLMS=IALLMS,KPTRMS=IPTRMS) ISPEC2_G = (ISMAX+1)*(ISMAX+2) ELSE ISPEC2 = D%NSPEC2 ISPEC2_G = R%NSPEC2_G IPOSSP(:) = D%NPOSSP(:) IDIM0G(:) = D%NDIM0G(:) ISPEC2MX = D%NSPEC2MX IUMPP(:) = D%NUMPP(:) IALLMS(:) = D%NALLMS(:) IPTRMS(:) = D%NPTRMS(:) ENDIF DO J=0,ISMAX IKN(J)=2*(ISMAX+1-J) ENDDO IFSEND = 0 IFRECV = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'DIST_SPEC:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('DIST_SPEC:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PSPECG)) THEN CALL ABORT_TRANS('DIST_SPEC:PSPECG MISSING') ENDIF IF(UBOUND(PSPECG,IFLD) < IFSEND) THEN WRITE(NERR,*) 'DIST_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFSEND CALL ABORT_TRANS('DIST_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL') ENDIF IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN WRITE(NERR,*) 'DIST_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G CALL ABORT_TRANS('DIST_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL') ENDIF ENDIF IF(PRESENT(KVSET)) THEN IF(UBOUND(KVSET,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_SPEC: KVSET TOO SHORT!') ENDIF DO J=1,KFDISTG IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN WRITE(NERR,*) 'DIST_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV CALL ABORT_TRANS('DIST_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE') ENDIF IF(KVSET(J) == MYSETV) THEN IFRECV = IFRECV+1 ENDIF ENDDO IVSET(:) = KVSET(1:KFDISTG) ELSE IFRECV = KFDISTG IVSET(:) = MYSETV ENDIF IF(IFRECV > 0 ) THEN IF(.NOT.PRESENT(PSPEC)) THEN CALL ABORT_TRANS('DIST_SPEC: FIELDS TO RECEIVE AND PSPEC NOT PRESENT') ENDIF IF(UBOUND(PSPEC,IFLD) < IFRECV) THEN CALL ABORT_TRANS('DIST_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL') ENDIF IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN CALL ABORT_TRANS('DIST_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (.NOT. PRESENT (PSPEC)) THEN CALL ABORT_TRANS('DIST_SPEC: KSORT REQUIRES PSPEC') ENDIF IF (UBOUND (KSORT, 1) /= UBOUND (PSPEC, IFLD)) THEN CALL ABORT_TRANS('DIST_SPEC: DIMENSION MISMATCH KSORT, PSPEC') ENDIF ENDIF CALL DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,IVSET,PSPEC,LLDIM1_IS_FLD,& & ISMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,KSORT) DEALLOCATE(IDIM0G) IF (LHOOK) CALL DR_HOOK('DIST_SPEC',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE DIST_SPEC ectrans-1.8.0/src/trans/cpu/external/dist_grid.F900000664000175000017500000001034115174631767022142 0ustar alastairalastair! (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 DIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) !**** *DIST_GRID* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:) - Local spectral array ! KSORT (:) - Re-order fields on output ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! P.Marguinaud : 10-10-14 Add KSORT ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE SET_RESOL_MOD ,ONLY : SET_RESOL USE DIST_GRID_CTL_MOD ,ONLY : DIST_GRID_CTL 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(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFSEND,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('DIST_GRID',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KFROM,1) < KFDISTG) THEN CALL ABORT_TRANS('DIST_GRID: KFROM TOO SHORT!') ENDIF IFSEND = 0 DO J=1,KFDISTG IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN WRITE(NERR,*) 'DIST_GRID:ILLEGAL KFROM VALUE',KFROM(J),J CALL ABORT_TRANS('DIST_GRID:ILLEGAL KFROM VALUE') ENDIF IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'DIST_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('DIST_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFDISTG) THEN WRITE(NOUT,*)'DIST_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFDISTG CALL ABORT_TRANS('DIST_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'DIST_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('DIST_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFSEND > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('DIST_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('DIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFSEND) THEN CALL ABORT_TRANS('DIST_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF IF (PRESENT (KSORT)) THEN IF (UBOUND (KSORT, 1) /= UBOUND (PGP, 2)) THEN CALL ABORT_TRANS('DIST_GRID: DIMENSION MISMATCH KSORT, PGP') ENDIF ENDIF CALL DIST_GRID_CTL(PGPG,KFDISTG,IPROMA,KFROM,PGP,KSORT) IF (LHOOK) CALL DR_HOOK('DIST_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID ectrans-1.8.0/src/trans/cpu/external/gath_grid_32.F900000664000175000017500000000770115174631767022434 0ustar alastairalastair! (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 GATH_GRID_32(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *GATH_GRID_32* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL GATH_GRID_32(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_32_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRM !ifndef INTERFACE USE TPM_GEN, ONLY : NERR,NOUT USE TPM_DISTR, ONLY : D, NPROC, MYPROC USE SET_RESOL_MOD, ONLY: SET_RESOL USE GATH_GRID_32_CTL_MOD, ONLY: GATH_GRID_32_CTL USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRM) , INTENT(IN) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFRECV,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GATH_GRID_32',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_GRID_32: KTO TOO SHORT!') ENDIF IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_GRID_32:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_GRID_32:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'GATH_GRID_32:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('GATH_GRID_32:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFGATHG) THEN WRITE(NOUT,*)'GATH_GRID_32:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFGATHG CALL ABORT_TRANS('GATH_GRID_32:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'GATH_GRID_32:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('GATH_GRID_32:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('GATH_GRID_32:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('GATH_GRID_32:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFRECV) THEN CALL ABORT_TRANS('GATH_GRID_32:SECOND DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL GATH_GRID_32_CTL(PGPG,KFGATHG,IPROMA,KTO,PGP) IF (LHOOK) CALL DR_HOOK('GATH_GRID_32',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID_32 ectrans-1.8.0/src/trans/cpu/external/inv_transad.F900000664000175000017500000005344715174631767022520 0ustar alastairalastair! (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 resolution (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 ectrans-1.8.0/src/trans/cpu/external/gath_grid.F900000664000175000017500000000761115174631767022130 0ustar alastairalastair! (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 GATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *GATH_GRID* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL GATH_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resolution (input) ! PGP(:,:,:) - Local gridpoint array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT USE TPM_DISTR ,ONLY : D, MYPROC, NPROC USE SET_RESOL_MOD ,ONLY : SET_RESOL USE GATH_GRID_CTL_MOD ,ONLY : GATH_GRID_CTL 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) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(IN) :: PGP(:,:,:) !ifndef INTERFACE INTEGER(KIND=JPIM) :: IFRECV,J,IUBOUND(3),IPROMA,IGPBLKS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GATH_GRID',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) IPROMA = D%NGPTOT IF(PRESENT(KPROMA)) THEN IPROMA = KPROMA ENDIF IGPBLKS = (D%NGPTOT-1)/IPROMA+1 IF(UBOUND(KTO,1) < KFGATHG) THEN CALL ABORT_TRANS('GATH_GRID: KTO TOO SHORT!') ENDIF IFRECV = 0 DO J=1,KFGATHG IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN WRITE(NERR,*) 'GATH_GRID:ILLEGAL KTO VALUE',KTO(J),J CALL ABORT_TRANS('GATH_GRID:ILLEGAL KTO VALUE') ENDIF IF(KTO(J) == MYPROC) IFRECV = IFRECV+1 ENDDO IUBOUND=UBOUND(PGP) IF(IUBOUND(1) < IPROMA) THEN WRITE(NOUT,*)'GATH_GRID:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),IPROMA CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < KFGATHG) THEN WRITE(NOUT,*)'GATH_GRID:SEC. DIM. OF PGP TOO SMALL ',IUBOUND(2),KFGATHG CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < IGPBLKS) THEN WRITE(NOUT,*)'GATH_GRID:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),IGPBLKS CALL ABORT_TRANS('GATH_GRID:THIRD DIMENSION OF PGP TOO SMALL ') ENDIF IF(IFRECV > 0) THEN IF(.NOT.PRESENT(PGPG)) THEN CALL ABORT_TRANS('GATH_GRID:PGPG MISSING') ENDIF IF(UBOUND(PGPG,1) < D%NGPTOTG) THEN CALL ABORT_TRANS('GATH_GRID:FIRST DIMENSION OF PGPG TOO SMALL') ENDIF IF(UBOUND(PGPG,2) < IFRECV) THEN CALL ABORT_TRANS('GATH_GRID:SECOND DIMENSION OF PGPG TOO SMALL') ENDIF ENDIF CALL GATH_GRID_CTL(PGPG,KFGATHG,IPROMA,KTO,PGP) IF (LHOOK) CALL DR_HOOK('GATH_GRID',1,ZHOOK_HANDLE) !endif INTERFACE ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID ectrans-1.8.0/src/trans/cpu/external/inv_trans.F900000664000175000017500000005400115174631767022176 0ustar alastairalastair! (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_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & FSPGL_PROC,& & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,LDLATLON,KPROMA,KVSETUV,KVSETSC,KRESOL,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANS* - Inverse spectral transform. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform !** Interface. ! ---------- ! CALL INV_TRANS(...) ! Explicit arguments : All arguments 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. ! LDLATLON - indicating if regular lat-lon output requested ! 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 resolution (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 ! ---------- LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields ! and derivatives (IF_SCALARS_G) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : NERR, NOUT, NPROMATR USE TPM_TRANS ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, LATLON, & & 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_CTL_MOD ,ONLY : INV_TRANS_CTL 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(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDSCDERS LOGICAL ,OPTIONAL, INTENT(IN) :: LDVORGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDDIVGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDUVDER LOGICAL ,OPTIONAL, INTENT(IN) :: LDLATLON 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(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: 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_TRANS',0,ZHOOK_HANDLE) CALL GSTATS(1807,0) ! Set current resolution CALL SET_RESOL(KRESOL) ! Set defaults LVORGP = .FALSE. LDIVGP = .FALSE. LUVDER = .FALSE. LATLON =.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_TRANS:KVSETUV(J) > NPRTRV ',J,KVSETUV(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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(.NOT. PRESENT(PSPSCALAR) ) THEN CALL ABORT_TRANS('INV_TRANS : KVSETSC PRESENT BUT PSPSCALAR MISSING') ENDIF IF_SCALARS_G = UBOUND(KVSETSC,1) DO J=1,IF_SCALARS_G IF(KVSETSC(J) > NPRTRV .OR. KVSETSC(J) < 1) THEN WRITE(NERR,*) 'INV_TRANS:KVSETSC(J) > NPRTRV ',J,KVSETSC(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_TRANS: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_TRANS:KVSETSC2(J) > NPRTRV ',J,KVSETSC2(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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 + IF_SC2_G NF_SC2 = UBOUND(PSPSC2,1) ENDIF IF(PRESENT(KVSETSC3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:KVSETSC3A(J) > NPRTRV ',J,KVSETSC3A(J),NPRTRV CALL ABORT_TRANS& &('INV_TRANS: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_TRANS: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_TRANS:KVSETSC3B(J) > NPRTRV ',J,KVSETSC3B(J),NPRTRV CALL ABORT_TRANS('INV_TRANS: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_G > 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 IF(PRESENT(LDLATLON)) THEN LATLON = LDLATLON 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_TRANS : IF_UV > 0 BUT PSPVOR MISSING') ENDIF IF(UBOUND(PSPVOR,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPVOR,1) < IF_UV ',UBOUND(PSPVOR,1),IF_UV CALL ABORT_TRANS('INV_TRANS : PSPVOR TOO SHORT') ENDIF IF(.NOT. PRESENT(PSPDIV) ) THEN CALL ABORT_TRANS('INV_TRANS : IF_UV > 0 BUT PSPDIV MISSING') ENDIF IF(UBOUND(PSPDIV,1) < IF_UV) THEN WRITE(NERR,*)'INV_TRANS : UBOUND(PSPDIV,1) < IF_UV ',UBOUND(PSPDIV,1),IF_UV CALL ABORT_TRANS('INV_TRANS : 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: 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_TRANS: SPECIFY VERTICAL SPECTRAL DISTRIBUTION!') ENDIF ENDIF IF(PRESENT(PGP)) THEN IF(PRESENT(PGPUV)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGPUV CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3A)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3A CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP3B)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP3B CAN NOT BOTH BE PRESENT') ENDIF IF(PRESENT(PGP2)) THEN CALL ABORT_TRANS('INV_TRANS:PGP AND PGP2 CAN NOT BOTH BE PRESENT') ENDIF IUBOUND(1:3)=UBOUND(PGP) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGP TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(2) < IF_GP) THEN WRITE(NOUT,*)'INV_TRANS: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_TRANS:SECOND DIMENSION OF PGP TOO SMALL ') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS: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_TRANS:ALTERNATIVES TO USING PGP NOT SUPPORTED WITH NPROMATR>0') ENDIF ENDIF IF(PRESENT(PGPUV)) THEN IF(.NOT.PRESENT(PSPVOR)) THEN CALL ABORT_TRANS('INV_TRANS:PSPVOR HAS TO BE PRESENT WHEN PGPUV IS') ENDIF IUBOUND(1:4)=UBOUND(PGPUV) IF(IUBOUND(1) < NPROMA) THEN WRITE(NOUT,*)'INV_TRANS:FIRST DIM. OF PGPUV TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_UV_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGPUV INCONSISTENT ',IUBOUND(2),IF_UV_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGPUV INCONSISTENT ') ENDIF IF(IUBOUND(3) < IF_UV_PAR) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGPUV TOO SMALL ',IUBOUND(3),IF_UV_PAR CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGPUV TOO SMALL ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGPUV TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGPUV TOO SMALL ') ENDIF ENDIF IF(PRESENT(PGP2)) THEN IF(.NOT.PRESENT(PSPSC2)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP2 TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP2 TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC2_G) THEN WRITE(NOUT,*)'INV_TRANS:SEC. DIM. OF PGP2 INCONSISTENT ',IUBOUND(2),IF_SC2_G CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP2 INCONSISTENT') ENDIF IF(IUBOUND(3) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP2 TOO SMALL ',IUBOUND(3),NGPBLKS CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP2 TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP2 MISSING') ENDIF ENDIF IF(PRESENT(PGP3A)) THEN IF(.NOT.PRESENT(PSPSC3A)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3A TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3A TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3A_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3A INCONSISTENT ',IUBOUND(2),IF_SC3A_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3A_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3A INCONSISTENT ',& & IUBOUND(3),IF_SC3A_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3A INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3A TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3A TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3A MISSING') ENDIF ENDIF IF(PRESENT(PGP3B)) THEN IF(.NOT.PRESENT(PSPSC3B)) THEN CALL ABORT_TRANS('INV_TRANS: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_TRANS:FIRST DIM. OF PGP3B TOO SMALL ',IUBOUND(1),NPROMA CALL ABORT_TRANS('INV_TRANS:FIRST DIMENSION OF PGP3B TOO SMALL ') ENDIF IF(IUBOUND(2) /= IF_SC3B_G2) THEN WRITE(NOUT,*)'INV_TRANS:SEC DIM. OF PGP3B INCONSISTENT ',IUBOUND(2),IF_SC3B_G2 CALL ABORT_TRANS('INV_TRANS:SEC. DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(3) /= IF_SC3B_G3 ) THEN WRITE(NOUT,*)'INV_TRANS:THIRD DIM. OF PGP3B INCONSISTENT ',& & IUBOUND(3),IF_SC3B_G3 CALL ABORT_TRANS('INV_TRANS:THIRD DIMENSION OF PGP3B INCONSISTENT ') ENDIF IF(IUBOUND(4) < NGPBLKS) THEN WRITE(NOUT,*)'INV_TRANS:FOURTH DIM. OF PGP3B TOO SMALL ',IUBOUND(4),NGPBLKS CALL ABORT_TRANS('INV_TRANS:FOURTH DIMENSION OF PGP3B TOO SMALL ') ENDIF ELSE CALL ABORT_TRANS('INV_TRANS:PGP3B MISSING') ENDIF ENDIF CALL GSTATS(1807,1) ! ------------------------------------------------------------------ ! Perform transform CALL INV_TRANS_CTL(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,FSPGL_PROC,& & PSPSC3A,PSPSC3B,PSPSC2,KVSETSC3A,KVSETSC3B,KVSETSC2,PGPUV,PGP3A,PGP3B,PGP2) IF (LHOOK) CALL DR_HOOK('INV_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE INV_TRANS ectrans-1.8.0/src/trans/cpu/external/gpnorm_trans.F900000664000175000017500000000564015174631767022711 0ustar alastairalastair! (C) Copyright 2008- ECMWF. ! (C) Copyright 2008- 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 GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !**** *GPNORM_TRANS* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL GPNORM_TRANS(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! Modifications. ! -------------- ! Original : 19th Sept 2008 ! R. El Khatib 07-08-2009 Optimisation directive for NEC ! R. El Khatib 16-Sep-2019 merge with LAM code ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F USE SET_RESOL_MOD ,ONLY : SET_RESOL USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE GPNORM_TRANS_CTL_MOD, ONLY : GPNORM_TRANS_CTL !endif INTERFACE IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL ,INTENT(IN) :: LDAVE_ONLY INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL !ifndef INTERFACE ! Local variables REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS',0,ZHOOK_HANDLE) ! Set current resolution CALL SET_RESOL(KRESOL) CALL GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,F%RW) IF (LHOOK) CALL DR_HOOK('GPNORM_TRANS',1,ZHOOK_HANDLE) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE GPNORM_TRANS ectrans-1.8.0/src/trans/cpu/external/trans_pnm.F900000664000175000017500000001117415174631767022200 0ustar alastairalastair! (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 TRANS_PNM(KRESOL,KM,PRPNM,LDTRANSPOSE,LDCHEAP) !**** *TRANS_PNM* - Compute Legendre polynomials for a given wavenember ! Purpose. ! -------- ! Interface routine for computing Legendre polynomials for a given wavenember !** Interface. ! ---------- ! CALL TRANS_PNM(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resolution (input) ! KM - wave number ! PRPNM - Legendre polynomials ! LDTRANSPOSE - Legendre polynomials array is transposed ! LDCHEAP - cheapest but less accurate computation ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 22-Jan-2016 from G. Mozdzynski's getpnm ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPRD, JPIM, JPRB !ifndef INTERFACE USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D USE TPM_GEOMETRY ,ONLY : G USE TPM_FIELDS ,ONLY : F USE TPM_FLT ,ONLY : S USE SET_RESOL_MOD ,ONLY : SET_RESOL USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS USE TPM_POL ,ONLY : INI_POL, END_POL USE SUPOLF_MOD ,ONLY : SUPOLF !endif INTERFACE IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) ,INTENT(IN) :: KM REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PRPNM(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: LDTRANSPOSE LOGICAL, OPTIONAL, INTENT(IN) :: LDCHEAP !ifndef INTERFACE INTEGER(KIND=JPIM) :: IU1, IU2, IMAXN, INMAX, ICHEAP_SYM, ICHEAP_ANTISYM INTEGER(KIND=JPIM) :: JN, JGL, JI INTEGER(KIND=JPIM) :: IA, IS, IDGLU, ILA, ILS, ISL REAL(KIND=JPRD), ALLOCATABLE :: ZLPOL(:) LOGICAL :: LLTRANSPOSE, LLCHEAP ! ------------------------------------------------------------------ ! Set current resolution IF (PRESENT(KRESOL)) THEN CALL SET_RESOL(KRESOL) ENDIF IF (PRESENT(LDTRANSPOSE)) THEN LLTRANSPOSE=LDTRANSPOSE ELSE LLTRANSPOSE=.FALSE. ENDIF IF (PRESENT(LDCHEAP)) THEN LLCHEAP=LDCHEAP ELSE LLCHEAP=.FALSE. ENDIF IF (LLCHEAP) THEN ICHEAP_SYM =2 ICHEAP_ANTISYM=3 ELSE ICHEAP_SYM =1 ICHEAP_ANTISYM=1 ENDIF IF (PRESENT(PRPNM)) THEN IF(D%LGRIDONLY) THEN CALL ABORT_TRANS('TRANS_PNM: PRPNM REQUIRED BUT LGRIDONLY=T') ENDIF ENDIF IU1 = UBOUND(PRPNM,1) IU2 = UBOUND(PRPNM,2) IF (LLTRANSPOSE) THEN IF(IU2 < R%NLEI3) THEN CALL ABORT_TRANS('TRANS_PNM : FIRST DIM. OF PRPNM TOO SMALL') ENDIF IF(IU1 < R%NTMAX-KM+3) THEN CALL ABORT_TRANS('TRANS_PNM : SECOND DIM. OF PRPNM TOO SMALL') ENDIF IF (IU2 >= R%NLEI3) THEN PRPNM(:,R%NLEI3) = 0.0_JPRB ENDIF ELSE IF(IU1 < R%NLEI3) THEN CALL ABORT_TRANS('TRANS_PNM : FIRST DIM. OF PRPNM TOO SMALL') ENDIF IF(IU2 < R%NTMAX-KM+3) THEN CALL ABORT_TRANS('TRANS_PNM : SECOND DIM. OF PRPNM TOO SMALL') ENDIF IF (IU1 >= R%NLEI3) THEN PRPNM(R%NLEI3,:) = 0.0_JPRB ENDIF ENDIF ILA = (R%NTMAX-KM+2)/2 ILS = (R%NTMAX-KM+3)/2 CALL INI_POL(R%NTMAX+2,LDFAST=.TRUE.) IMAXN=R%NTMAX+1 IA = 1+MOD(R%NTMAX-KM+2,2) IS = 1+MOD(R%NTMAX-KM+1,2) ISL = MAX(R%NDGNH-G%NDGLU(KM)+1,1) IF (S%LSOUTHPNM) THEN IDGLU = 2*MIN(R%NDGNH,G%NDGLU(KM)) ELSE IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) ENDIF IF(MOD(IMAXN-KM,2) == 0) THEN INMAX=IMAXN+1 ELSE INMAX=IMAXN ENDIF ALLOCATE(ZLPOL(0:R%NTMAX+2)) !$OMP PARALLEL DO SCHEDULE(DYNAMIC,1) PRIVATE(JGL,ZLPOL,JI,JN) DO JGL=1,IDGLU CALL SUPOLF(KM,INMAX,F%RMU(ISL+JGL-1),ZLPOL(0:INMAX),KCHEAP=ICHEAP_ANTISYM) IF (LLTRANSPOSE) THEN DO JI=1,ILA PRPNM(IA+(JI-1)*2,ISL+JGL-1) = ZLPOL(KM+2*(ILA-JI)+1) ENDDO ELSE DO JI=1,ILA PRPNM(ISL+JGL-1,IA+(JI-1)*2) = ZLPOL(KM+2*(ILA-JI)+1) ENDDO ENDIF CALL SUPOLF(KM,INMAX,F%RMU(ISL+JGL-1),ZLPOL(0:INMAX),KCHEAP=ICHEAP_SYM) IF (LLTRANSPOSE) THEN DO JI=1,ILS PRPNM(IS+(JI-1)*2,ISL+JGL-1) = ZLPOL(KM+2*(ILS-JI)) ENDDO ELSE DO JI=1,ILS PRPNM(ISL+JGL-1,IS+(JI-1)*2) = ZLPOL(KM+2*(ILS-JI)) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO CALL END_POL ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE TRANS_PNM ectrans-1.8.0/src/trans/cpu/external/trans_end.F900000664000175000017500000000623115174631767022152 0ustar alastairalastair! (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 TRANS_END(CDMODE) !**** *TRANS_END* - Terminate transform package ! Purpose. ! -------- ! Terminate transform package. Release all allocated arrays. !** Interface. ! ---------- ! CALL TRANS_END ! Explicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! G. Radnoti: 19-03-2009: intermediate end of transf to allow to switch to mono-task transforms ! R. El Khatib 09-Jul-2013 LENABLED ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB !ifndef INTERFACE USE TPM_GEN ,ONLY : MSETUP0, NCUR_RESOL, NMAX_RESOL, LENABLED,NDEF_RESOL USE TPM_DIM ,ONLY : R, DIM_RESOL USE TPM_DISTR ,ONLY : D, DISTR_RESOL, NPRCIDS USE TPM_GEOMETRY ,ONLY : G, GEOM_RESOL USE TPM_FIELDS ,ONLY : F, FIELDS_RESOL USE TPM_CTL ,ONLY : C, CTL_RESOL USE TPM_FFTW ,ONLY : TW, FFTW_RESOL USE TPM_FLT ,ONLY : S, FLT_RESOL USE TPM_TRANS ,ONLY : FOUBUF, FOUBUF_IN USE EQ_REGIONS_MOD ,ONLY : N_REGIONS USE SET_RESOL_MOD ,ONLY : SET_RESOL USE DEALLOC_RESOL_MOD ,ONLY : DEALLOC_RESOL ! IMPLICIT NONE CHARACTER(LEN=5), OPTIONAL, INTENT(IN) :: CDMODE ! Local variables INTEGER(KIND=JPIM) :: JRES CHARACTER(LEN=5) :: CLMODE ! ------------------------------------------------------------------ CLMODE='FINAL' IF (PRESENT(CDMODE)) CLMODE=CDMODE IF (CLMODE == 'FINAL') THEN IF( ALLOCATED( LENABLED ) ) THEN DO JRES=1,NMAX_RESOL IF(LENABLED(JRES)) THEN CALL DEALLOC_RESOL(JRES) ENDIF ENDDO DEALLOCATE(LENABLED) ENDIF NULLIFY(R) IF( ALLOCATED(DIM_RESOL) ) DEALLOCATE(DIM_RESOL) NULLIFY(D) IF( ALLOCATED(DISTR_RESOL) ) DEALLOCATE(DISTR_RESOL) !TPM_FFTW NULLIFY(TW) IF( ALLOCATED(FFTW_RESOL) ) DEALLOCATE(FFTW_RESOL) !TPM_FLT NULLIFY(S) IF( ALLOCATED(FLT_RESOL) ) DEALLOCATE(FLT_RESOL) !TPM_CTL NULLIFY(C) IF( ALLOCATED(CTL_RESOL) ) DEALLOCATE(CTL_RESOL) !TPM_FIELDS NULLIFY(F) IF( ALLOCATED(FIELDS_RESOL) ) DEALLOCATE(FIELDS_RESOL) !TPM_GEOMETRY NULLIFY(G) IF( ALLOCATED(GEOM_RESOL) ) DEALLOCATE(GEOM_RESOL) !TPM_TRANS IF(ALLOCATED(FOUBUF_IN)) DEALLOCATE(FOUBUF_IN) IF(ALLOCATED(FOUBUF)) DEALLOCATE(FOUBUF) MSETUP0 = 0 NMAX_RESOL = 0 NCUR_RESOL = 0 NDEF_RESOL = 0 ENDIF IF (CLMODE == 'FINAL' .OR. CLMODE == 'INTER') THEN !EQ_REGIONS IF( ASSOCIATED(N_REGIONS) ) DEALLOCATE(N_REGIONS) !TPM_DISTR IF( ALLOCATED(NPRCIDS) ) DEALLOCATE(NPRCIDS) ENDIF ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE TRANS_END ectrans-1.8.0/src/trans/cpu/maybe_unused/0000775000175000017500000000000015174631767020551 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/maybe_unused/external/0000775000175000017500000000000015174631767022373 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/maybe_unused/external/sugawc.F900000775000175000017500000000501515174631767024150 0ustar alastairalastair! (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 SUGAWC(KDGLG,PMU,PW) !**** *SUGAWC* - Compute Gaussian latitudes and weights ! Purpose. ! -------- ! Compute Gaussian latitudes and weights. !** Interface. ! ---------- ! CALL SUGAWC(...) ! Explicit arguments : ! -------------------- ! INPUT: ! KDGLG - number of latitudes. ! OUTPUT: ! PMU - sine of Gaussian latitudes. ! PW - Gaussian weights. ! Method. ! ------- ! Externals. SUGAW ! ---------- ! Author. ! ------- ! K. Yessad, from SUGAWA and SULEG (trans) ! Original : May 2012 ! Modifications. ! -------------- ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPRD, JPIM !ifndef INTERFACE USE SUGAW_MOD, ONLY : SUGAW !endif INTERFACE ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KDGLG REAL(KIND=JPRD) ,INTENT(OUT) :: PMU(:) REAL(KIND=JPRD) ,INTENT(OUT) :: PW(:) !ifndef INTERFACE REAL(KIND=JPRD) :: ZANM INTEGER(KIND=JPIM) :: ISTART,IODD,JN,JGL REAL(KIND=JPRD) :: ZFN(0:KDGLG,0:KDGLG) REAL(KIND=JPRD) :: ZFNN ! ------------------------------------------------------------------ ! * preliminary calculations to compute input quantities ZANM and ZFN ! (k.y.: coded after what I found in tfl/module/suleg_mod.F90). ISTART=1 ! Belousov, Swarztrauber use ZFN(0,0)=SQRT(2._JPRD) ! IFS normalisation chosen to be 0.5*Integral(Pnm**2) = 1 ZFN(0,0)=2._JPRD DO JN=ISTART,KDGLG ZFNN=ZFN(0,0) DO JGL=1,JN ZFNN=ZFNN*SQRT(1._JPRD-0.25_JPRD/REAL(JGL**2,JPRD)) ENDDO IODD=MOD(JN,2) ZFN(JN,JN)=ZFNN DO JGL=2,JN-IODD,2 ZFN(JN,JN-JGL)=ZFN(JN,JN-JGL+2)*REAL((JGL-1)*(2*JN-JGL+2),JPRD)/REAL(JGL*(2*JN-JGL+1),JPRD) ENDDO ENDDO ZANM=SQRT(REAL(2*KDGLG+1,JPRD)*REAL(KDGLG**2,JPRD)/REAL(2*KDGLG-1,JPRD)) ! * call to SUGAW (output: PW, PMU): CALL SUGAW(KDGLG,0,KDGLG,PMU,PW,ZANM,ZFN) ! ------------------------------------------------------------------ !endif INTERFACE END SUBROUTINE SUGAWC ectrans-1.8.0/src/trans/cpu/maybe_unused/include/0000775000175000017500000000000015174631767022174 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/maybe_unused/include/ectrans/0000775000175000017500000000000015174631767023633 5ustar alastairalastairectrans-1.8.0/src/trans/cpu/maybe_unused/include/ectrans/sugawc.h0000664000175000017500000000265415174631767025304 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE SUGAWC(KDGLG,PMU,PW) !**** *SUGAWC* - Compute Gaussian latitudes and weights ! Purpose. ! -------- ! Compute Gaussian latitudes and weights. !** Interface. ! ---------- ! CALL SUGAWC(...) ! Explicit arguments : ! -------------------- ! INPUT: ! KDGLG - number of latitudes. ! OUTPUT: ! PMU - sine of Gaussian latitudes. ! PW - Gaussian weights. ! Method. ! ------- ! Externals. SUGAW ! ---------- ! Author. ! ------- ! K. Yessad, from SUGAWA and SULEG (trans) ! Original : May 2012 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM ,JPRD ! ------------------------------------------------------------------ IMPLICIT NONE INTEGER(KIND=JPIM) ,INTENT(IN) :: KDGLG REAL(KIND=JPRD) ,INTENT(OUT) :: PMU(:) REAL(KIND=JPRD) ,INTENT(OUT) :: PW(:) END SUBROUTINE SUGAWC END INTERFACE ectrans-1.8.0/src/trans/cpu/CMakeLists.txt0000664000175000017500000001235515174631767020637 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. ## Apply workarounds for some known compilers if(CMAKE_Fortran_COMPILER_ID MATCHES "Cray") if( CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 8.7 ) # Fix for IFS "CONGRAD: SPTSV/DPTSV returned non-zero info with crayftn 8.7.7 (cdt/18.12) ectrans_add_compile_options( SOURCES internal/ftinv_ctlad_mod.F90 FLAGS "-O0,fp1,omp") endif() endif() if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") if( CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 18 AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 19 ) # See https://github.com/ecmwf-ifs/ectrans/issues/17 ectrans_add_compile_options( SOURCES algor/butterfly_alg_mod.F90 FLAGS "-check nopointers") endif() endif() function(generate_backend_sources) set (options) set (oneValueArgs BACKEND DESTINATION OUTPUT) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(backend ${_PAR_BACKEND}) set(destination ${_PAR_DESTINATION}) file(MAKE_DIRECTORY ${destination}/algor) file(MAKE_DIRECTORY ${destination}/internal) file(MAKE_DIRECTORY ${destination}/external) ecbuild_list_add_pattern( LIST files GLOB algor/*.F90 internal/*.F90 external/*.F90 QUIET ) set(outfiles) foreach(file_i ${files}) get_filename_component(outfile_name ${file_i} NAME) get_filename_component(outfile_name_we ${file_i} NAME_WE) get_filename_component(outfile_ext ${file_i} EXT) get_filename_component(outfile_dir ${file_i} DIRECTORY) set(outfile "${destination}/${file_i}") ecbuild_debug("Generate ${outfile}") generate_file(BACKEND ${backend} INPUT ${CMAKE_CURRENT_SOURCE_DIR}/${file_i} OUTPUT ${outfile}) list(APPEND outfiles ${outfile}) endforeach(file_i) set(${_PAR_OUTPUT} ${outfiles} PARENT_SCOPE) endfunction(generate_backend_sources) set( BUILD_INTERFACE_INCLUDE_DIR ${CMAKE_BINARY_DIR}/include/ectrans ) foreach( prec dp sp ) if( HAVE_${prec} ) generate_backend_includes(BACKEND ${prec} TARGET ectrans_${prec}_includes DESTINATION ${BUILD_INTERFACE_INCLUDE_DIR} INCLUDE_DIRECTORY ${PROJECT_SOURCE_DIR}/src/trans/include ) generate_backend_sources( BACKEND ${prec} OUTPUT ectrans_${prec}_src DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/generated/ectrans_${prec}) ecbuild_add_library( TARGET ectrans_${prec} LINKER_LANGUAGE Fortran SOURCES ${ectrans_${prec}_src} PUBLIC_INCLUDES $ $ $ PUBLIC_LIBS fiat ectrans_common ectrans_${prec}_includes ) ecbuild_target_fortran_module_directory( TARGET ectrans_${prec} MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/module/ectrans INSTALL_MODULE_DIRECTORY module/ectrans ) set( FFTW_LINK PRIVATE ) if( LAPACK_LIBRARIES MATCHES "mkl" AND NOT FFTW_LIBRARIES MATCHES "mkl" ) ecbuild_warn( "Danger: Both MKL and FFTW are linked in trans_${prec}. " "No guarantees on link order can be made for the final executable.") set( FFTW_LINK PUBLIC ) # Attempt anyway to give FFTW precedence endif() ecbuild_debug("target_link_libraries( trans_${prec} ${FFTW_LINK} ${FFTW_LIBRARIES} )") target_link_libraries( ectrans_${prec} ${FFTW_LINK} ${FFTW_LIBRARIES} ) target_include_directories( ectrans_${prec} PRIVATE ${FFTW_INCLUDE_DIRS} ) target_compile_definitions( ectrans_${prec} PRIVATE WITH_FFTW ) ecbuild_debug("target_link_libraries( ectrans_${prec} PRIVATE ${LAPACK_LIBRARIES} )") target_link_libraries( ectrans_${prec} PRIVATE ${LAPACK_LIBRARIES} ) if( HAVE_OMP ) ecbuild_debug("target_link_libraries( ectrans_${prec} PRIVATE OpenMP::OpenMP_Fortran )") target_link_libraries( ectrans_${prec} PRIVATE OpenMP::OpenMP_Fortran ) endif() if( ECTRANS_HAVE_CONTIGUOUS_ISSUE ) # See https://github.com/ecmwf-ifs/ectrans/pull/98 # There is a problem with CONTIGUOUS keyword in dist_spec_control_mod.F90 ecbuild_debug("target_compile_definitions( ectrans_${prec} PRIVATE CONTIG_BUGGY_COMPILER)") target_compile_definitions( ectrans_${prec} PRIVATE CONTIG_BUGGY_COMPILER) endif() # This interface library is for backward compatibility, and provides the older includes ecbuild_add_library( TARGET trans_${prec} TYPE INTERFACE ) target_include_directories( trans_${prec} INTERFACE $ ) target_include_directories( trans_${prec} INTERFACE $ ) target_link_libraries( trans_${prec} INTERFACE fiat ectrans_${prec} parkind_${prec}) endif() endforeach() ## Install trans interface install( DIRECTORY ${BUILD_INTERFACE_INCLUDE_DIR}/ DESTINATION include/ectrans ) ectrans-1.8.0/src/trans/include/0000775000175000017500000000000015174631767016725 5ustar alastairalastairectrans-1.8.0/src/trans/include/ectrans/0000775000175000017500000000000015174631767020364 5ustar alastairalastairectrans-1.8.0/src/trans/include/ectrans/trans_inq.h0000664000175000017500000002013715174631767022536 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE TRANS_INQ(KRESOL,KSPEC,KSPEC2,KSPEC2G,KSPEC2MX,KNUMP,& &KGPTOT,KGPTOTG,KGPTOTMX,KGPTOTL,& &KMYMS,KASM0,KUMPP,KPOSSP,KPTRMS,KALLMS,KDIM0G,& &KFRSTLAT,KLSTLAT,KFRSTLOFF,KPTRLAT,& &KPTRFRSTLAT,KPTRLSTLAT,KPTRFLOFF,KSTA,KONL,& &KULTPP,KPTRLS,KNMENG,& &KPRTRW,KMYSETW,KMYSETV,KMY_REGION_NS,KMY_REGION_EW,& &LDSPLITLAT,& &KSMAX,PLAPIN,KNVALUE,KDEF_RESOL,LDLAM,& &PMU,PGW,PRPNM,KLEI3,KSPOLEGL,KPMS,KDGLU) !**** *TRANS_INQ* - Extract information from the transform package ! Purpose. ! -------- ! Interface routine for extracting information from the T.P. !** Interface. ! ---------- ! CALL TRANS_INQ(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resulution (input) ! MULTI-TRANSFORMS MANAGEMENT ! KDEF_RESOL - number or resolutions defined ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! SPECTRAL SPACE ! KSPEC - number of complex spectral coefficients on this PE ! KSPEC2 - 2*KSPEC ! KSPEC2G - global KSPEC2 ! KSPEC2MX - maximun KSPEC2 among all PEs ! KNUMP - Number of spectral waves handled by this PE ! KGPTOT - Total number of grid columns on this PE ! KGPTOTG - Total number of grid columns on the Globe ! KGPTOTMX - Maximum number of grid columns on any of the PEs ! KGPTOTL - Number of grid columns one each PE (dimension N_REGIONS_NS:N_REGIONS_EW) ! KMYMS - This PEs spectral zonal wavenumbers ! KASM0 - Address in a spectral array of (m, n=m) ! KUMPP - No. of wave numbers each wave set is responsible for ! KPOSSP - Defines partitioning of global spectral fields among PEs ! KPTRMS - Pointer to the first wave number of a given a-set ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order ! KDIM0G - Defines partitioning of global spectral fields among PEs ! KSMAX - spectral truncation ! KNVALUE - n value for each KSPEC2 spectral coeffient ! GRIDPOINT SPACE ! KFRSTLAT - First latitude of each a-set in grid-point space ! KLSTTLAT - Last latitude of each a-set in grid-point space ! KFRSTLOFF - Offset for first lat of own a-set in grid-point space ! KPTRLAT - Pointer to the start of each latitude ! KPTRFRSTLAT - Pointer to the first latitude of each a-set in ! NSTA and NONL arrays ! KPTRLSTLAT - Pointer to the last latitude of each a-set in ! NSTA and NONL arrays ! KPTRFLOFF - Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 ! KSTA - Position of first grid column for the latitudes on a ! processor. The information is available for all processors. ! The b-sets are distinguished by the last dimension of ! nsta().The latitude band for each a-set is addressed by ! nptrfrstlat(jaset),nptrlstlat(jaset), and ! nptrfloff=nptrfrstlat(myseta) on this processors a-set. ! Each split latitude has two entries in nsta(,:) which ! necessitates the rather complex addressing of nsta(,:) ! and the overdimensioning of nsta by N_REGIONS_NS. ! KONL - Number of grid columns for the latitudes on a processor. ! Similar to nsta() in data structure. ! LDSPLITLAT - TRUE if latitude is split in grid point space over ! two a-sets ! FOURIER SPACE ! KULTPP - number of latitudes for which each a-set is calculating ! the FFT's. ! KPTRLS - pointer to first global latitude of each a-set for which ! it performs the Fourier calculations ! KNMENG - associated (with NLOENG) cut-off zonal wavenumber ! LEGENDRE ! PMU - sin(Gaussian latitudes) ! PGW - Gaussian weights ! PRPNM - Legendre polynomials ! KLEI3 - First dimension of Legendre polynomials ! KSPOLEGL - Second dimension of Legendre polynomials ! KPMS - Adress for legendre polynomial for given M (NSMAX) ! PLAPIN - Eigen-values of the inverse Laplace operator ! KDGLU - Number of active points in an hemisphere for a given wavenumber "m" ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! M. Hortal : 2001-03-05 Dimensions of the Legendre polynomials ! R. El Khatib 08-Aug-2012 KSMAX,PLAPIN,KNVALUE,LDLAM,KDEF_RESOL ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2G INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPEC2MX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNUMP INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOT INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTG INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTMX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KGPTOTL(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KFRSTLOFF INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRFLOFF INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KASM0(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KUMPP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPOSSP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KALLMS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDIM0G(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KFRSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KLSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRFRSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLSTLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSTA(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KONL(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPRTRW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETW INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMYSETV INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_NS INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KMY_REGION_EW LOGICAL ,OPTIONAL, INTENT(OUT) :: LDSPLITLAT(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KULTPP(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPTRLS(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNMENG(:) REAL(KIND=JPRD) ,OPTIONAL, INTENT(OUT) :: PMU(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGW(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PRPNM(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KLEI3 INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSPOLEGL INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KPMS(0:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDGLU(0:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PLAPIN(-1:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KNVALUE(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(OUT) :: KDEF_RESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM END SUBROUTINE TRANS_INQ END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/gath_grid_32.h0000664000175000017500000000373515174631767023001 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE GATH_GRID_32(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *GATH_GRID_32* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL GATH_GRID_32(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_32_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRM IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRM) , INTENT(IN) :: PGP(:,:,:) ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID_32 END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/trans_end.h0000664000175000017500000000215615174631767022516 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE TRANS_END(CDMODE) !**** *TRANS_END* - Terminate transform package ! Purpose. ! -------- ! Terminate transform package. Release all allocated arrays. !** Interface. ! ---------- ! CALL TRANS_END ! Explicit arguments : None ! -------------------- ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE CHARACTER*5, OPTIONAL, INTENT(IN) :: CDMODE END SUBROUTINE TRANS_END END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/gpnorm_trans.h0000664000175000017500000000436415174631767023255 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE GPNORM_TRANS(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,KRESOL) !**** *GPNORM_TRANS* - calculate grid-point norms ! Purpose. ! -------- ! calculate grid-point norms using a 2 stage (NPRTRV,NPRTRW) communication rather ! than an approach using a more expensive global gather collective communication !** Interface. ! ---------- ! CALL GPNORM_TRANS(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! PMIN - minimum (input/output) ! PMAX - maximum (input/output) ! LDAVE_ONLY - T : PMIN and PMAX already contain local MIN and MAX ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! George Mozdzynski *ECMWF* ! Modifications. ! -------------- ! Original : 19th Sept 2008 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB),INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB),INTENT(OUT) :: PAVE(:) REAL(KIND=JPRB),INTENT(INOUT) :: PMIN(:) REAL(KIND=JPRB),INTENT(INOUT) :: PMAX(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA LOGICAL,INTENT(IN) :: LDAVE_ONLY INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL END SUBROUTINE GPNORM_TRANS END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/dir_trans.h0000664000175000017500000001457415174631767022535 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE DIR_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & LDLATLON,KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANS* - Direct spectral transform (from grid-point to spectral). ! Purpose. ! -------- ! Interface routine for the direct spectral transform !** Interface. ! ---------- ! CALL DIR_TRANS(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! LDLATLON - indicating if regular lat-lon is the input data ! 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 (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- LTDIR_CTL - control of Legendre transform ! FTDIR_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB 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(:,:) 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 LOGICAL ,OPTIONAL, INTENT(IN) :: LDLATLON 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(:,:,:) END SUBROUTINE DIR_TRANS END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/inv_transad.h0000664000175000017500000001720115174631767023046 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE 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 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(:,:,:) END SUBROUTINE INV_TRANSAD END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/vordiv_to_uv.h0000664000175000017500000000417715174631767023273 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE VORDIV_TO_UV(PSPVOR,PSPDIV,PSPU,PSPV,KSMAX,KVSETUV) !**** *VORDIV_TO_UV* - Convert spectral vorticity and divergence to spectral U (u*cos(theta)) and V (v*cos(theta). ! Purpose. ! -------- ! Interface routine for Convert spectral vorticity and divergence to spectral U and V !** Interface. ! ---------- ! CALL VORDIV_TO_UV(...) ! Explicit arguments : ! -------------------- ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPU(:,:) - spectral U (u*cos(theta) (output) ! PSPV(:,:) - spectral V (v*cos(theta) (output) ! KSMAX - spectral resolution (input) ! KVSETUV(:) - Optionally 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. ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- VD2UV_CTL - control vordiv to uv ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 15-06-15 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB), INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB), INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PSPU(:,:) REAL(KIND=JPRB), INTENT(OUT) :: PSPV(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSETUV(:) END SUBROUTINE VORDIV_TO_UV END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/dist_spec.h0000664000175000017500000000423515174631767022516 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE DIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,& & LDIM1_IS_FLD,KSMAX,KSORT) !**** *DIST_SPEC* - Distribute global spectral array among processors ! Purpose. ! -------- ! Interface routine for distributing spectral array !** Interface. ! ---------- ! CALL DIST__SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KFROM(:) - Processor resposible for distributing each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PSPEC(:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) ! ------------------------------------------------------------------ END SUBROUTINE DIST_SPEC END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/get_current.h0000664000175000017500000000253715174631767023065 0ustar alastairalastair! (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. INTERFACE SUBROUTINE GET_CURRENT(KRESOL,LDLAM) !**** *GET_CURRENT* - Extract current information from the transform package ! Purpose. ! -------- ! Interface routine for extracting current information from the T.P. !** Interface. ! ---------- ! CALL GET_CURRENT(...) ! Explicit arguments : (all optional) ! -------------------- ! KRESOL - Current resolution ! LDLAM - .T. if the corresponding resolution is LAM, .F. if it is global ! Method. ! ------- ! Externals. None ! ---------- ! Author. ! ------- ! Ryad El Khatib *Meteo-France* ! Modifications. ! -------------- ! Original : 24-Aug-2012 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: KRESOL LOGICAL ,OPTIONAL,INTENT(OUT) :: LDLAM END SUBROUTINE GET_CURRENT END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/dist_grid.h0000664000175000017500000000404415174631767022507 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE DIST_GRID(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP,KSORT) !**** *DIST_GRID* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(OUT) :: PGP(:,:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSORT (:) ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/gath_grid.h0000664000175000017500000000371615174631767022474 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE GATH_GRID(PGPG,KPROMA,KFGATHG,KTO,KRESOL,PGP) !**** *GATH_GRID* - Gather global gridpoint array from processors ! Purpose. ! -------- ! Interface routine for gathering gripoint array !** Interface. ! ---------- ! CALL GATH_GRID(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global gridpoint array ! KFGATHG - Global number of fields to be gathered ! KPROMA - blocking factor for gridpoint input ! KTO(:) - Processor responsible for gathering each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_GRID_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) , INTENT(IN) :: PGP(:,:,:) ! ------------------------------------------------------------------ END SUBROUTINE GATH_GRID END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/gpnorm_transad.h0000664000175000017500000000347415174631767023563 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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. ! INTERFACE SUBROUTINE GPNORM_TRANSAD(PGP,KFIELDS,KPROMA,PAVE,KRESOL) !**** *GPNORM_TRANSAD* - calculate grid-point norms ! (adjoint version) ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL GPNORM_TRANSAD(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! Filip Vana ! (c) ECMWF 14-Aug-2024 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB) ,INTENT(INOUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA INTEGER(KIND=JPIM),OPTIONAL, INTENT(IN) :: KRESOL END SUBROUTINE GPNORM_TRANSAD END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/dist_grid_32.h0000664000175000017500000000377415174631767023024 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE DIST_GRID_32(PGPG,KPROMA,KFDISTG,KFROM,KRESOL,PGP) !**** *DIST_GRID_32* - Distribute global gridpoint array among processors ! Purpose. ! -------- ! Interface routine for distributing gridpoint array !** Interface. ! ---------- ! CALL DIST_GRID_32(...) ! Explicit arguments : ! -------------------- ! PGPG(:,:) - Global spectral array ! KFDISTG - Global number of fields to be distributed ! KPROMA - required blocking factor for gridpoint input ! KFROM(:) - Processor resposible for distributing each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PGP(:,:) - Local spectral array ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIST_GRID_32_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRM IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRM) ,OPTIONAL, INTENT(IN) :: PGPG(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) , INTENT(IN) :: KFDISTG INTEGER(KIND=JPIM) , INTENT(IN) :: KFROM(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRM) , INTENT(OUT) :: PGP(:,:,:) ! ------------------------------------------------------------------ END SUBROUTINE DIST_GRID_32 END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/setup_trans.h0000664000175000017500000001125315174631767023106 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE SETUP_TRANS(KSMAX,KDGL,KDLON,KLOEN,LDSPLIT,PSTRET,& &KTMAX,KRESOL,PWEIGHT,LDGRIDONLY,LDUSERPNM,LDKEEPRPNM,LDUSEFLT,& &LDSPSETUPONLY,LDPNMONLY,LDUSEFFTW,LD_ALL_FFTW,& &LDLL,LDSHIFTLL,CDIO_LEGPOL,CDLEGPOLFNAME,KLEGPOLPTR,KLEGPOLPTR_LEN) !**** *SETUP_TRANS* - Setup transform package for specific resolution ! Purpose. ! -------- ! To setup for making spectral transforms. Each call to this routine ! creates a new resolution up to a maximum of NMAX_RESOL set up in ! SETUP_TRANS0. You need to call SETUP_TRANS0 before this routine can ! be called. !** Interface. ! ---------- ! CALL SETUP_TRANS(...) ! Explicit arguments : KLOEN,LDSPLIT are optional arguments ! -------------------- ! KSMAX - spectral truncation required ! KDGL - number of Gaussian latitudes ! KDLON - number of points on each latitude [2*KDGL] ! KLOEN(:) - number of points on each Gaussian latitude [2*KDGL] ! LDSPLIT - true if split latitudes in grid-point space [false] ! KTMAX - truncation order for tendencies? ! KRESOL - the resolution identifier ! PWEIGHT - the weight per grid-point (for a weighted distribution); ! Note, only seems to be used from within enkf ! LDGRIDONLY - true if only grid space is required ! KSMAX,KDGL,KTMAX and KLOEN are GLOBAL variables desribing the resolution ! in spectral and grid-point space ! LDSPLIT describe the distribution among processors of grid-point data and ! has no relevance if you are using a single processor ! LDUSEFLT - use Fast Legandre Transform (Butterfly algorithm) ! LDUSERPNM - Use Belusov to compute legendre pol. (else new alg.) ! LDKEEPRPNM - Keep Legendre Polynomials (only applicable when using ! FLT, otherwise always kept) ! LDPNMONLY - Compute the Legendre polynomialsonly, not the FFTs. ! LDUSEFFTW - Use FFTW for FFTs (option deprecated - FFTW is now mandatory) ! LD_ALL_FFTW : T to transform all fields in one call, F to transforms fields one after another ! LDLL - Setup second set of input/output latitudes ! the number of input/output latitudes to transform is equal KDGL ! or KDGL+2 in the case that includes poles + equator ! the number of input/output longitudes to transform is 2*KDGL ! LDSHIFTLL - Shift output lon/lat data by 0.5*dx and 0.5*dy ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- SETUP_DIMS - setup distribution independent dimensions ! SUMP_TRANS_PRELEG - first part of setup of distr. environment ! SULEG - Compute Legandre polonomial and Gaussian ! Latitudes and Weights ! SUMP_TRANS - Second part of setup of distributed environment ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRD USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT,C_ASSOCIATED,C_SIZE_T IMPLICIT NONE ! Dummy arguments INTEGER(KIND=JPIM) ,INTENT(IN) :: KSMAX,KDGL INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KDLON INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KLOEN(:) LOGICAL ,OPTIONAL,INTENT(IN) :: LDSPLIT INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KTMAX INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT):: KRESOL REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PWEIGHT(:) REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PSTRET LOGICAL ,OPTIONAL,INTENT(IN):: LDGRIDONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFLT LOGICAL ,OPTIONAL,INTENT(IN):: LD_ALL_FFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDUSERPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDKEEPRPNM LOGICAL ,OPTIONAL,INTENT(IN):: LDPNMONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDSPSETUPONLY LOGICAL ,OPTIONAL,INTENT(IN):: LDUSEFFTW LOGICAL ,OPTIONAL,INTENT(IN):: LDLL LOGICAL ,OPTIONAL,INTENT(IN):: LDSHIFTLL CHARACTER(LEN=*),OPTIONAL,INTENT(IN):: CDIO_LEGPOL CHARACTER(LEN=*),OPTIONAL,INTENT(IN):: CDLEGPOLFNAME TYPE(C_PTR) ,OPTIONAL,INTENT(IN) :: KLEGPOLPTR INTEGER(C_SIZE_T) ,OPTIONAL,INTENT(IN) :: KLEGPOLPTR_LEN END SUBROUTINE SETUP_TRANS END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/gath_spec.h0000664000175000017500000000434515174631767022500 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE GATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,LDZA0IP) !**** *GATH_SPEC* - Gather global spectral array from processors ! Purpose. ! -------- ! Interface routine for gathering spectral array !** Interface. ! ---------- ! CALL GATH_SPEC(...) ! Explicit arguments : ! -------------------- ! PSPECG(:,:) - Global spectral array ! KFGATHG - Global number of fields to be gathered ! KTO(:) - Processor responsible for gathering each field ! KVSET(:) - "B-Set" for each field ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PSPEC(:,:) - Local spectral array ! LDIM1_IS_FLD - If TRUE first dimension of PSCPEC and PSPECG is the field dimension [.T.] ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- GATH_SPEC_CONTROL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(OUT) :: PSPECG(:,:) INTEGER(KIND=JPIM) , INTENT(IN) :: KFGATHG INTEGER(KIND=JPIM) , INTENT(IN) :: KTO(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDIM1_IS_FLD INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KSMAX LOGICAL ,OPTIONAL, INTENT(IN) :: LDZA0IP ! ------------------------------------------------------------------ END SUBROUTINE GATH_SPEC END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/gpnorm_transtl.h0000664000175000017500000000350115174631767023605 0ustar alastairalastair! (C) Copyright 2024- ECMWF. ! ! 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. ! INTERFACE SUBROUTINE GPNORM_TRANSTL(PGP,KFIELDS,KPROMA,PAVE,KRESOL) !**** *GPNORM_TRANSTL* - calculate grid-point norms ! reduced version for linear model ! Purpose. ! -------- ! calculate grid-point norms !** Interface. ! ---------- ! CALL GPNORM_TRANSTL(...) ! Explicit arguments : ! -------------------- ! PGP(:,:,:) - gridpoint fields (input) ! PGP is dimensioned (NPROMA,KFIELDS,NGPBLKS) where ! NPROMA is the blocking factor, KFIELDS the total number ! of fields and NGPBLKS the number of NPROMA blocks. ! KFIELDS - number of fields (input) ! (these do not have to be just levels) ! KPROMA - required blocking factor (input) ! PAVE - average (output) ! KRESOL - resolution tag (optional) ! default assumes first defined resolution ! ! Author. ! ------- ! Filip Vana, (c) ECMWF ! 9-Sep-2024 ! Modifications. ! -------------- ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB),INTENT(IN) :: PGP(:,:,:) REAL(KIND=JPRB),INTENT(OUT) :: PAVE(:) INTEGER(KIND=JPIM),INTENT(IN) :: KFIELDS INTEGER(KIND=JPIM),INTENT(IN) :: KPROMA INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL END SUBROUTINE GPNORM_TRANSTL END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/inv_trans.h0000664000175000017500000001752615174631767022553 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE INV_TRANS(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & FSPGL_PROC,& & LDSCDERS,LDVORGP,LDDIVGP,LDUVDER,LDLATLON,KPROMA,KVSETUV,KVSETSC,KRESOL,& & KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *INV_TRANS* - Inverse spectral transform. ! Purpose. ! -------- ! Interface routine for the inverse spectral transform !** Interface. ! ---------- ! CALL INV_TRANS(...) ! Explicit arguments : All arguments 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. ! LDLATLON - indicating if regular lat-lon output requested ! 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 ! ---------- LTINV_CTL - control of Legendre transform ! FTINV_CTL - control of Fourier transform ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! 26-02-03 Mats Hamrud & Gabor Radnoti : modified condition for scalar fields ! and derivatives (IF_SCALARS_G) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPSC2(:,:) LOGICAL ,OPTIONAL, INTENT(IN) :: LDSCDERS LOGICAL ,OPTIONAL, INTENT(IN) :: LDVORGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDDIVGP LOGICAL ,OPTIONAL, INTENT(IN) :: LDUVDER LOGICAL ,OPTIONAL, INTENT(IN) :: LDLATLON 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(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) END SUBROUTINE INV_TRANS END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/specnorm.h0000664000175000017500000000362615174631767022372 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE SPECNORM(PNORM,PSPEC,KVSET,KMASTER,KRESOL,PMET) !**** *SPECNORM* - Compute global spectral norms ! Purpose. ! -------- ! Interface routine for computing spectral norms !** Interface. ! ---------- ! CALL SPECNORM(...) ! Explicit arguments : All arguments optional ! -------------------- ! PSPEC(:,:) - Spectral array ! KVSET(:) - "B-Set" for each field ! KMASTER - processor to recieve norms ! KRESOL - resolution tag which is required ,default is the ! first defined resulution (input) ! PMET(:) - metric ! PNORM(:) - Norms (output for processor KMASTER) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- SPNORM_CTL - control routine ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) , INTENT(OUT) :: PNORM(:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PSPEC(:,:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KVSET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KMASTER REAL(KIND=JPRB) ,OPTIONAL, INTENT(IN) :: PMET(:) INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL ! ------------------------------------------------------------------ END SUBROUTINE SPECNORM END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/trans_pnm.h0000664000175000017500000000332515174631767022541 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE TRANS_PNM(KRESOL,KM,PRPNM,LDTRANSPOSE,LDCHEAP) !**** *TRANS_PNM* - Compute Legendre polynomials for a given wavenember ! Purpose. ! -------- ! Interface routine for computing Legendre polynomials for a given wavenember !** Interface. ! ---------- ! CALL TRANS_PNM(...) ! Explicit arguments : All arguments are optional. ! -------------------- ! KRESOL - resolution tag for which info is required ,default is the ! first defined resulution (input) ! KM - wave number ! PRPNM - Legendre polynomials ! LDTRANSPOSE - Legendre polynomials array is transposed ! LDCHEAP - cheapest but less accurate computation ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- ! Author. ! ------- ! R. El Khatib *METEO-FRANCE* ! Modifications. ! -------------- ! Original : 22-Jan-2016 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KRESOL INTEGER(KIND=JPIM) ,INTENT(IN) :: KM REAL(KIND=JPRB) ,INTENT(OUT) :: PRPNM(:,:) LOGICAL, OPTIONAL, INTENT(IN) :: LDTRANSPOSE LOGICAL, OPTIONAL, INTENT(IN) :: LDCHEAP END SUBROUTINE TRANS_PNM END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/ini_spec_dist.h0000664000175000017500000000571415174631767023360 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE INI_SPEC_DIST(KSMAX,KTMAX,KPRTRW,KMYSETW,KASM0,KSPOLEGL,KPROCM,& &KUMPP,KSPEC,KSPEC2,KSPEC2MX,KPOSSP,KMYMS,KPTRMS,KALLMS) !**** *INI_SPEC_DIST* - Initialize spectral wave distribution ! Purpose. ! -------- ! Initialize arrays controlling spectral wave distribution !** Interface. ! ---------- ! CALL INI_SPEC_DIST(...) ! Explicit arguments : ! -------------------- ! KSMAX - spectral truncation required ! KTMAX - Overtruncation for KSMAX (input) ! KPRTRW - Number of processors in A-direction (input) ! KMYSETW - A-set for present processor (input) ! KASM0 - Offsets for spectral waves (output) ! KSPOLEGL - Local version of NSPOLEG (output) ! KPROCM - Where a certain spectral wave belongs (output) ! KUMPP - Number of spectral waves on this PE (output) ! KSPEC - Local version on NSPEC (output) ! KSPEC2 - Local version on NSPEC2 (output) ! KSPEC2MX - Maximum KSPEC2 across PEs (output) ! KPOSSP - Global spectral fields partitioning (output) ! KMYMS - This PEs spectral zonal wavenumbers (output) ! KPTRMS - Pointer to the first wave number of a given a-set (output) ! KALLMS - Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order (output) ! Implicit arguments : NONE ! -------------------- ! Method. ! ------- ! See documentation ! Externals. SUWAVEDI ! ---------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE EC_PARKIND, ONLY: JPIM IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KSMAX INTEGER(KIND=JPIM),INTENT(IN) :: KTMAX INTEGER(KIND=JPIM),INTENT(IN) :: KPRTRW INTEGER(KIND=JPIM),INTENT(IN) :: KMYSETW INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC2 INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPEC2MX INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KSPOLEGL INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KASM0(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPROCM(0:KSMAX) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KUMPP(KPRTRW) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPOSSP(KPRTRW+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMYMS(KSMAX+1) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KPTRMS(KPRTRW) INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KALLMS(KSMAX+1) END SUBROUTINE INI_SPEC_DIST END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/trans_release.h0000664000175000017500000000107215174631767023364 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE TRANS_RELEASE(KRESOL) USE PARKIND1 ,ONLY : JPIM INTEGER(KIND=JPIM),INTENT(IN) :: KRESOL END SUBROUTINE TRANS_RELEASE END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/setup_trans0.h0000664000175000017500000000711015174631767023163 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& & KPRGPNS,KPRGPEW,KPRTRW,KCOMBFLEN,& & LDMPOFF,LDSYNC_TRANS,KTRANS_SYNC_LEVEL,& & LDEQ_REGIONS,K_REGIONS_NS,K_REGIONS_EW,K_REGIONS,& & PRAD,LDALLOPERM,KOPT_MEMORY_TR) !**** *SETUP_TRANS0* - General setup routine for transform package ! Purpose. ! -------- ! Resolution independent part of setup of transform package ! Has to be called BEFORE SETUP_TRANS !** Interface. ! ---------- ! CALL SETUP_TRANS0(...) ! Explicit arguments : All arguments are optional, [..] default value ! ------------------- ! KOUT - Unit number for listing output [6] ! KERR - Unit number for error messages [0] ! KPRINTLEV - level of output to KOUT, 0->no output,1->normal,2->debug [0] ! KMAX_RESOL - maximum number of different resolutions for this run [1] ! KPRGPNS - splitting level in N-S direction in grid-point space [1] ! KPRGPEW - splitting level in E-W direction in grid-point space [1] ! KPRTRW - splitting level in wave direction in spectral space [1] ! KCOMBFLEN - Size of communication buffer [1800000 (*8bytes) ] (deprecated) ! LDMPOFF - switch off message passing [false] ! LDSYNC_TRANS - switch to activate barrier before transforms [false] ! KTRANS_SYNC_LEVEL - use of synchronization/blocking [0] ! LDEQ_REGIONS - true if new eq_regions partitioning [false] ! K_REGIONS - Number of regions (1D or 2D partitioning) ! K_REGIONS_NS - Maximum number of NS partitions ! K_REGIONS_EW - Maximum number of EW partitions ! PRAD - Radius of the planet ! LDALLOPERM - Allocate certain arrays permanently ! KOPT_MEMORY_TR - memory strategy (stack vs heap) in gripoint transpositions ! The total number of (MPI)-processors has to be equal to KPRGPNS*KPRGPEW ! Method. ! ------- ! Externals. SUMP_TRANS0 - initial setup routine ! ---------- ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! R. El Khatib 03-01-24 LDMPOFF ! G. Mozdzynski 2006-09-13 LDEQ_REGIONS ! N. Wedi 2009-11-30 add radius ! R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR ! ------------------------------------------------------------------ USE EC_PARKIND ,ONLY : JPIM ,JPRD IMPLICIT NONE INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KPRGPNS,KPRGPEW,KPRTRW,KCOMBFLEN LOGICAL ,OPTIONAL,INTENT(IN) :: LDMPOFF LOGICAL ,OPTIONAL,INTENT(IN) :: LDSYNC_TRANS INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KTRANS_SYNC_LEVEL LOGICAL ,OPTIONAL,INTENT(IN) :: LDEQ_REGIONS LOGICAL ,OPTIONAL,INTENT(IN) :: LDALLOPERM REAL(KIND=JPRD) ,OPTIONAL,INTENT(IN) :: PRAD INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(IN) :: KOPT_MEMORY_TR INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS(:) INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_NS INTEGER(KIND=JPIM) ,OPTIONAL,INTENT(OUT) :: K_REGIONS_EW END SUBROUTINE SETUP_TRANS0 END INTERFACE ectrans-1.8.0/src/trans/include/ectrans/dir_transad.h0000664000175000017500000001434215174631767023033 0ustar alastairalastair! (C) Copyright 2000- ECMWF. ! (C) Copyright 2013- 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. ! INTERFACE SUBROUTINE DIR_TRANSAD(PSPVOR,PSPDIV,PSPSCALAR,PSPSC3A,PSPSC3B,PSPSC2,& & KPROMA,KVSETUV,KVSETSC,KRESOL,KVSETSC3A,KVSETSC3B,KVSETSC2,& & PGP,PGPUV,PGP3A,PGP3B,PGP2) !**** *DIR_TRANSAD* - Direct spectral transform - adjoint. ! Purpose. ! -------- ! Interface routine for the direct spectral transform - adjoint !** Interface. ! ---------- ! CALL DIR_TRANSAD(...) ! Explicit arguments : All arguments except from PGP are optional. ! -------------------- ! PSPVOR(:,:) - spectral vorticity (output) ! PSPDIV(:,:) - spectral divergence (output) ! PSPSCALAR(:,:) - spectral scalarvalued fields (output) ! 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) ! 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 (input) ! 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): ! ! 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) ! ! 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 DIR_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) ! PGP3A(:,:,:,:) - grid-point array directly connected with PSPSC3A ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3A ) ! PGP3B(:,:,:,:) - grid-point array directly connected with PSPSC3B ! dimensioned(NPROMA,ILEVS,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC3B) ! PGP2(:,:,:) - grid-point array directly connected with PSPSC2 ! dimensioned(NPROMA,IFLDS,NGPBLKS) ! IFLDS is the number of 'variables' (the same as in ! PSPSC2 ) ! ! Method. ! ------- ! Externals. SET_RESOL - set resolution ! ---------- DIR_TRANS_CTLAD - control routine ! ! Author. ! ------- ! Mats Hamrud *ECMWF* ! Modifications. ! -------------- ! Original : 00-03-03 ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB IMPLICIT NONE ! Declaration of arguments REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPVOR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPDIV(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSCALAR(:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3A(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC3B(:,:,:) REAL(KIND=JPRB) ,OPTIONAL, INTENT(INOUT) :: PSPSC2(:,:) 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 REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP(:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGPUV(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3A(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP3B(:,:,:,:) REAL(KIND=JPRB),OPTIONAL ,INTENT(OUT) :: PGP2(:,:,:) END SUBROUTINE DIR_TRANSAD END INTERFACE ectrans-1.8.0/src/trans/CMakeLists.txt0000664000175000017500000001053615174631767020047 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. function(generate_file) set (options) set (oneValueArgs INPUT OUTPUT BACKEND) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(output ${_PAR_OUTPUT}) set(input ${_PAR_INPUT}) set(backend ${_PAR_BACKEND}) set(sed_rules ${PROJECT_SOURCE_DIR}/src/trans/sedrenames.txt) set( JPRB_dp JPRD ) set( jprb_dp jprd ) set( JPRB_sp JPRM ) set( jprb_sp jprm ) set( JPRB_gpu_dp JPRD ) set( jprb_gpu_dp jprd ) set( JPRB_gpu_sp JPRM ) set( jprb_gpu_sp jprm ) add_custom_command( OUTPUT ${output} COMMAND cat ${sed_rules} | sed -e "s/VARIANTDESIGNATOR/${backend}/g" | sed -e "s/TYPEDESIGNATOR_UPPER/${JPRB_${backend}}/g" | sed -e "s/TYPEDESIGNATOR_LOWER/${jprb_${backend}}/g" | sed -rf - ${input} > ${output} DEPENDS ${input} ${sed_rules} COMMENT "Generating ${output}" VERBATIM ) endfunction(generate_file) function(generate_backend_includes) set (options) set (oneValueArgs BACKEND TARGET DESTINATION INCLUDE_DIRECTORY) set (multiValueArgs) cmake_parse_arguments(_PAR "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) set(destination ${_PAR_DESTINATION} ) set(backend ${_PAR_BACKEND}) file(MAKE_DIRECTORY ${destination}) file(MAKE_DIRECTORY ${destination}/trans_${backend}) ecbuild_list_add_pattern( LIST absolute_files GLOB ectrans/*.h SOURCE_DIR ${_PAR_INCLUDE_DIRECTORY} QUIET ) set( files ) foreach(file_i ${absolute_files}) file(RELATIVE_PATH file_i ${_PAR_INCLUDE_DIRECTORY} ${file_i}) list(APPEND files ${file_i}) endforeach() set( outfiles ) foreach(file_i ${files}) get_filename_component(outfile_name ${file_i} NAME) get_filename_component(outfile_name_we ${file_i} NAME_WE) get_filename_component(outfile_ext ${file_i} EXT) get_filename_component(outfile_dir ${file_i} DIRECTORY) if (${file_i} IN_LIST ectrans_common_includes) configure_file(${_PAR_INCLUDE_DIRECTORY}/${file_i} ${destination}/${outfile_name}) else() set(outfile "${destination}/${outfile_name_we}_${backend}${outfile_ext}") ecbuild_debug("Generate ${outfile}") generate_file(BACKEND ${backend} INPUT ${_PAR_INCLUDE_DIRECTORY}/${file_i} OUTPUT ${outfile}) list(APPEND outfiles ${outfile}) string(TOUPPER ${outfile_name_we} OUTFILE_NAME_WE ) ecbuild_debug("Generate ${destination}/trans_${backend}/${outfile_name}") file(WRITE ${destination}/trans_${backend}/${outfile_name} "! Automatically generated interface header for backward compatibility of generic symbols !\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#if defined(${outfile_name_we})\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#undef ${outfile_name_we}\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#endif\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#if defined(${OUTFILE_NAME_WE})\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#undef ${OUTFILE_NAME_WE}\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#endif\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#include \"${outfile_name_we}_${backend}${outfile_ext}\"\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#define ${outfile_name_we} ${OUTFILE_NAME_WE}_${backend}\n") file(APPEND ${destination}/trans_${backend}/${outfile_name} "#define ${OUTFILE_NAME_WE} ${OUTFILE_NAME_WE}_${backend}\n") endif() endforeach(file_i) add_custom_target(${_PAR_TARGET}_generate DEPENDS ${outfiles}) ecbuild_add_library(TARGET ${_PAR_TARGET} TYPE INTERFACE) add_dependencies(${_PAR_TARGET} ${_PAR_TARGET}_generate) target_include_directories(${_PAR_TARGET} INTERFACE $) endfunction(generate_backend_includes) add_subdirectory( common ) if( HAVE_CPU) add_subdirectory( cpu ) endif() if( HAVE_GPU ) add_subdirectory( gpu ) endif() ectrans-1.8.0/src/transi/0000775000175000017500000000000015174631767015453 5ustar alastairalastairectrans-1.8.0/src/transi/transi.h0000664000175000017500000015263115174631767017134 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ /*! * @mainpage * This project declares the C-API to the IFS trans-library.\n * For documentation of all available functions, see @ref trans.h . * * @section About * * This library gives access to spectral transforms on the sphere. * The library is capable to take advantage of a MPI-distributed-memory environment, * and can use OpenMP-shared-memory parallelism internally. * * * @section Usage * * First ectrans needs to be initialized with a function trans_init(). * This needs to be done only once in the program. It sets up some * global structures independent of any resolution. * * A number of resolutions can now be setup using trans_setup() for each * resolution. * Every call to trans_setup() involves allocating and computing the * transformation coefficients, and should be done only once for * every intended resolution as it can be very expensive and requires * to store a lot of memory. The resolution can be referred to with * a trans "handle" of the Trans_t type. * * Using this handle, one can now transform fields. Either many fields * can be transformed simultaneously, or the transform functions can * be called multiple times to transform any number of fields separately. * * The function to do a transform from gridpoints to spectral is called trans_dirtrans(). * The function to do a transform from spectral to gridpoints is called trans_invtrans(). * The function to do the adjoint of the spectral to gridpoints transform is called trans_invtrans_adj(). * It also transforms the data from gridpoints to spectral. * * In case of distrubuted parallelism (MPI), the functions trans_dirtrans(), trans_invtrans(), * and trans_invtrans_adj() work on distributed fields. * In order to convert to and from a global view of the field * (e.g. for reading / writing), one can use the functions trans_distspec(), trans_gathspec(), * trans_distgrid(), trans_gathgrid(). * * Every handle needs to be cleaned up when no longer required, to release * the memory and coefficients stored internally. This can be done with the * function trans_delete(). * * Lastly, transi needs to be finalized with trans_finalize(), which will * clean up any remaining internal global structures * * @author Willem Deconinck * @date Jul 2014 */ /*! * @file transi.h * @brief C-interface to the IFS trans-library * * This file declares the C-API to the IFS trans-library * Definitions of routines are implemented in * trans_module.F90, which redirects function calls * to the IFS TRANS library * * @author Willem Deconinck (nawd) * @date Jul 2014 */ #ifndef ectrans_transi_h #define ectrans_transi_h #include // size_t typedef int _bool; #ifdef __cplusplus extern "C" { #endif #include "ectrans/version.h" #define TRANS_FFT992 1 #define TRANS_FFTW 2 #define TRANS_SUCCESS 0 struct Trans_t; struct DirTrans_t; struct DirTransAdj_t; struct InvTrans_t; struct InvTransAdj_t; struct DistGrid_t; struct GathGrid_t; struct DistSpec_t; struct GathSpec_t; struct VorDivToUV_t; struct SpecNorm_t; /*! @brief Get error message relating to error code */ const char* trans_error_msg(int errcode); /*! @brief Set limit on maximum simultaneously allocated transforms @note Advanced feature Default value is 10 This function needs to be called before trans_init() or trans_setup(), and ONLY if the default value needs to be changed. */ int trans_set_handles_limit(int limit); /*! @brief Set radius of planet used in trans @note Advanced feature Default value of radius is Earth's radius (6371.22e+03) This function needs to be called before trans_init() or trans_setup(), and ONLY if the default value needs to be changed. */ int trans_set_radius(double radius); /*! @brief Set nprtrv for parallel distribution of fields in spectral space @note Advanced feature Default value of nprtrv is 1, meaning that there is no parallel distribution of the same wave number for different fields (or levels) This function needs to be called before trans_init() or trans_setup(), and ONLY if the default value needs to be changed. */ int trans_set_nprtrv(int nprtrv); /*! @brief Set nprgpew for distribution of fields in gridpoint space @note Advanced feature Default value of nprgpew is 1, meaning that there is no parallel distribution of the same latitude This function needs to be called before trans_init() or trans_setup(), and ONLY if the default value needs to be changed. */ int trans_set_nprgpew(int nprgpew); /*! @brief Set leq_regions in trans @note Advanced feature Default value of leq_regions is true This function needs to be called before trans_init() or trans_setup(), and ONLY if the default value needs to be changed. */ int trans_set_leq_regions(_bool ldeq_regions); /*! @brief Use MPI in trans library. @note Advanced feature By default, MPI is used if MPI was detected during compilation. To force not to use MPI, this function may be used. */ int trans_use_mpi(_bool); /*! @brief Initialize trans library This initializes MPI communication, and allocates resolution-independent storage. \n If this routine is not called, then it will be called internally upon the first call to trans_setup() @pre call trans_set_radius() and/or trans_set_nprtrv() if radius or nprtrv need to be different from default values */ int trans_init(void); /*! @brief Set user-provided MPI communicator to be used by the trans library @note Advanced feature By default, the trans library will use its own MPI communicator (typically based on MPI_COMM_WORLD) when MPI support is enabled. This routine allows the caller to provide an alternative communicator that will be used by all subsequent trans operations. This function needs to be called before trans_init() or trans_setup(), and ONLY if the default communicator needs to be changed. @param[in] mpi_user_comm MPI communicator handle provided by the user. */ int trans_set_mpi_comm(int mpi_user_comm); int trans_set_read(struct Trans_t*, const char* filepath); int trans_set_write(struct Trans_t*, const char* filepath); int trans_set_cache(struct Trans_t*, const void*, size_t); /*! @brief Setup a new resolution to be used in the trans library @param trans Trans_t struct, that needs to have following variables defined: - ndgl -- number of lattitudes - nloen -- number of longitudes for each lattitude - nsmax -- spectral truncation wave number All scalar values in the struct will be filled in. Remaining array values will be deallocated and set to null. To define array values, make individual calls to trans_inquire() Usage: @code{.c} struct Trans_t trans; trans_new(&trans); trans.ndgl = ... ; trans.nloen = malloc( sizeof(int)*trans.ndgl ); ... // Read in or compute nloen values trans.nsmax = (2*trans.ndgl-1)/2; // For typical linear grid trans_setup(&trans); @endcode @note If trans_init() was not called beforehand, it will be called internally */ int trans_setup(struct Trans_t* trans); /*! @brief Inquire the trans library for array values @param trans Trans_t struct which needs to have been setup using trans_setup() @param varlist comma-separated string of values to inquire The inquired values will be allocated if needed, and filled in in the Trans_t struct */ int trans_inquire(struct Trans_t* trans, const char* varlist); /*! @brief Direct spectral transform (from grid-point to spectral) A DirTrans_t struct, initialised with new_dirtrans(), groups all arguments @param dirtrans DirTrans_t struct, containing all arguments. Usage: - Transform of scalar fields @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rgp = malloc( sizeof(double) * nscalar*trans.ngptot ); double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); struct DirTrans_t dirtrans = new_dirtrans(&trans); dirtrans.nscalar = nscalar; // input dirtrans.rgp = rgp; // input dirtrans.rspscalar = rspscalar; // output trans_dirtrans(&dirtrans); @endcode - Transform of U and V fields to vorticity and divergence @code struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rgp = malloc( sizeof(double) * 2*nvordiv*trans.ngptot ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); struct DirTrans_t dirtrans = new_dirtrans(&trans); dirtrans.nvordiv = nvordiv; // input dirtrans.rgp = rgp; // input -- order: U, V dirtrans.rspvor = rspvor; // output dirtrans.rspdiv = rspdiv; // output trans_dirtrans(&dirtrans); @endcode - Transform of U and V fields to vorticity and divergence, as well as scalar fields @code struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rgp = malloc( sizeof(double) * (2*nvordiv+nscalar)*trans.ngptot ); double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); struct DirTrans_t dirtrans = new_dirtrans(&trans); dirtrans.nvordiv = nvordiv; // input dirtrans.nscalar = nscalar; // input dirtrans.rgp = rgp; // input -- order: U, V, scalars dirtrans.rspscalar = rspscalar; // output dirtrans.rspvor = rspvor; // output dirtrans.rspdiv = rspdiv; // output trans_dirtrans(&dirtrans); @endcode @note trans_dirtrans works on distributed arrays */ int trans_dirtrans(struct DirTrans_t* dirtrans); /*! @brief Adjoint of the Direct spectral transform (from spectral to grid-point) A DirTransAdj_t struct, initialised with new_dirtrans_adj(), groups all arguments @param dirtrans_adj DirTransAdj_t struct, containing all arguments. Usage: - Adjoint of Transform of scalar fields @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rgp = malloc( sizeof(double) * nscalar*trans.ngptot ); double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); struct DirTransAdj_t dirtrans_adj = new_dirtrans_adj(&trans); dirtrans_adj.nscalar = nscalar; // input dirtrans_adj.rgp = rgp; // input dirtrans_adj.rspscalar = rspscalar; // output trans_dirtrans_adj(&dirtrans_adj); @endcode - Adjoint of Transform of U and V fields to vorticity and divergence @code struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rgp = malloc( sizeof(double) * 2*nvordiv*trans.ngptot ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); struct DirTransAdj_t dirtrans_adj = new_dirtrans_adj(&trans); dirtrans_adj.nvordiv = nvordiv; // input dirtrans_adj.rgp = rgp; // input -- order: U, V dirtrans_adj.rspvor = rspvor; // output dirtrans_adj.rspdiv = rspdiv; // output trans_dirtrans_adj(&dirtrans_adj); @endcode - Adjoint of Transform of U and V fields to vorticity and divergence, as well as scalar fields @code struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rgp = malloc( sizeof(double) * (2*nvordiv+nscalar)*trans.ngptot ); double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); struct DirTransAdj_t dirtrans_adj = new_dirtrans_adj(&trans); dirtrans_adj.nvordiv = nvordiv; // input dirtrans_adj.nscalar = nscalar; // input dirtrans_adj.rgp = rgp; // input -- order: U, V, scalars dirtrans_adj.rspscalar = rspscalar; // output dirtrans_adj.rspvor = rspvor; // output dirtrans_adj.rspdiv = rspdiv; // output trans_dirtrans_adj(&dirtrans_adj); @endcode @note trans_dirtrans_adj works on distributed arrays */ int trans_dirtrans_adj(struct DirTransAdj_t* dirtransadj); /*! @brief Inverse spectral transform (from spectral grid-point) A InvTrans_t struct, initialised with new_invtrans(), groups all arguments @param invtrans InvTrans_t struct, containing all arguments. Usage: - Transform of scalars @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rgp = malloc( sizeof(double) * nscalar*trans.ngptot ); // Inverse Transform struct InvTrans_t invtrans = new_invtrans(&trans); invtrans.nscalar = nscalar; // input invtrans.rspscalar = rspscalar; // input invtrans.rgp = rgp; // output trans_invtrans(&invtrans); @endcode - Transform vorticity and divergence to U and V @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rgp = malloc( sizeof(double) * 2*nvordiv*trans.ngptot ); // Inverse Transform struct InvTrans_t invtrans = new_invtrans(&trans); invtrans.nvordiv = nvordiv; // input invtrans.rspvor = rspvor; // input invtrans.rspdiv = rspdiv; // input invtrans.rgp = rgp; // output -- order: u, v trans_invtrans(&invtrans); @endcode - Transform of vorticity, divergence *and* scalars to U, V, scalars @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rgp = malloc( sizeof(double) * (2*nvordiv+nscalar)*trans.ngptot ); // Inverse Transform struct InvTrans_t invtrans = new_invtrans(&trans); invtrans.nscalar = nscalar; // input invtrans.nvordiv = nvordiv; // input invtrans.rspscalar = rspscalar; // input invtrans.rspvor = rspvor; // input invtrans.rspdiv = rspdiv; // input invtrans.rgp = rgp; // output -- order: u, v, scalars trans_invtrans(&invtrans); @endcode @note trans_invtrans works on distributed arrays */ int trans_invtrans(struct InvTrans_t* invtrans); /*! @brief Adjoint of the Inverse spectral transform (from grid-point spectral) A InvTransAdj_t struct, initialised with new_invtrans_adj(), groups all arguments @param invtrans_adj InvTransAdj_t struct, containing all arguments. Usage: - Transform of scalars @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rgp = malloc( sizeof(double) * nscalar*trans.ngptot ); // Adjoint of Inverse Transform struct InvTransAdj_t invtrans_adj = new_invtrans_adj(&trans); invtrans_adj.nscalar = nscalar; // input invtrans_adj.rspscalar = rspscalar; // output invtrans_adj.rgp = rgp; // input trans_invtrans_adj(&invtrans_adj); @endcode - Adjoint of Transform vorticity and divergence to U and V @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rgp = malloc( sizeof(double) * 2*nvordiv*trans.ngptot ); // Adjoint of Inverse Transform struct InvTransAdj_t invtrans_adj = new_invtrans_adj(&trans); invtrans_adj.nvordiv = nvordiv; // input invtrans_adj.rspvor = rspvor; // output invtrans_adj.rspdiv = rspdiv; // output invtrans_adj.rgp = rgp; // input -- order: u, v trans_invtrans_adj(&invtrans_adj); @endcode - Adjoint of Transform of vorticity, divergence *and* scalars to U, V, scalars @code{.c} struct Trans_t trans; trans_new(&trans); ... // Missing setup of trans double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); double* rspvor = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rspdiv = malloc( sizeof(double) * nvordiv*trans.nspec2 ); double* rgp = malloc( sizeof(double) * (2*nvordiv+nscalar)*trans.ngptot ); // Adjoint of Inverse Transform struct InvTransAdj_t invtrans_adj = new_invtrans_adj(&trans); invtrans_adj.nscalar = nscalar; // input invtrans_adj.nvordiv = nvordiv; // input invtrans_adj.rspscalar = rspscalar; // input invtrans_adj.rspvor = rspvor; // input invtrans_adj.rspdiv = rspdiv; // input invtrans_adj.rgp = rgp; // output -- order: u, v, scalars trans_invtrans_adj(&invtrans_adj); @endcode @note trans_invtrans_adj works on distributed arrays */ int trans_invtrans_adj(struct InvTransAdj_t* invtrans_adj); /*! @brief Distribute global gridpoint array among processors Usage: @code{.c} struct Trans_t trans; trans_new(&trans); ... // missing setup int nfld = 1; double* rgpg = NULL; if( trans.myproc == 1 ) // Load global field in proc 1 { rgpg = malloc( sizeof(double) * trans.ngptotg*nfld ); ... // load data in rgpg[nfld][ngptotg] } int* nfrom = malloc( sizeof(int) * nfld ); nfrom[0] = 1; // Global field 0 sits in proc 1 double* rgp = malloc( sizeof(double) * nfld*trans.ngptot ); struct DistGrid_t distgrid = new_distgrid(&trans); distgrid.nfrom = nfrom; distgrid.rgpg = rgpg; distgrid.rgp = rgp; distgrid.nfld = nfld; trans_distgrid(&distgrid); @endcode */ int trans_distgrid(struct DistGrid_t* distgrid); /*! @brief Gather global gridpoint array from processors Usage: @code{.c} struct Trans_t trans; trans_new(&trans); ... // missing setup // Distributed field int nfld = 1; double* rgp = malloc( sizeof(double) * nfld*trans.ngptot ); ... // load data in rgp[nfld][ngptot] // Global field double* rgpg = NULL; if( trans.myproc == 1 ) // We will gather to proc 1 { rgpg = malloc( sizeof(double) * nfld*trans.ngptotg ); } int* nto = malloc( sizeof(int) * nfld ); nto[0] = 1; // Gather global fields struct GathGrid_t gathgrid = new_gathgrid(&trans); gathgrid.rgp = rgp; gathgrid.rgpg = rgpg; gathgrid.nto = nto; gathgrid.nfld = nfld; trans_gathgrid(&gathgrid); @endcode */ int trans_gathgrid(struct GathGrid_t* gathgrid); /*! @brief Distribute global spectral array among processors Usage: @code{.c} struct Trans_t trans; trans_new(&trans); ... // missing setup // Global fields to be distributed int nscalar = 1; double* rspscalarg = NULL; if( trans.myproc == 1 ) { rspscalarg = malloc( sizeof(double) * nscalar*trans.nspec2g ); ... // load data in rspscalarg[nspec2g][nscalar] } int* nfrom = malloc( sizeof(int) * nscalar ); nfrom[0] = 1; // Distribute to local fields double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); struct DistSpec_t distspec = new_distspec(&trans); distspec.rspec = rspscalar; distspec.rspecg = rspscalarg; distspec.nfld = nscalar; distspec.nfrom = nto; trans_distspec(&distspec); @endcode */ int trans_distspec(struct DistSpec_t* distspec); /*! @brief Gather global spectral array from processors Usage: @code{.c} struct Trans_t trans; trans_new(&trans); ... // missing setup // We have some distributed spectral fields "rspscalar" int nscalar = 1; double* rspscalar = malloc( sizeof(double) * nscalar*trans.nspec2 ); ... // load data in rspscalar[nspec2][nscalar] // We want to gather to proc 1 double* rspscalarg = NULL; if( trans.myproc == 1 ) rspscalarg = malloc( sizeof(double) * nscalar*trans.nspec2g ); int* nto = malloc( sizeof(int) * nscalar ); nto[0] = 1; struct GathSpec_t gathspec = new_gathspec(&trans); gathspec.rspec = rspscalar; gathspec.rspecg = rspscalarg; gathspec.nfld = nscalar; gathspec.nto = nto; trans_gathspec(&gathspec); @endcode */ int trans_gathspec(struct GathSpec_t* gathspec); /*! @brief Convert Spectral vorticity & divergence to Spectral u*cos(theta) & v*cos(theta) Usage: @code{.c} // We have some global spectral fields for vorticity,divergence,u*cos(theta),v*cos(theta) int nfld = 1; double* rspvor = malloc( sizeof(double) * nfld*ncoeff ); double* rspdiv = malloc( sizeof(double) * nfld*ncoeff ); double* rspu = malloc( sizeof(double) * nfld*ncoeff ); double* rspv = malloc( sizeof(double) * nfld*ncoeff ); ... // load data in rspvor[ncoeff][nfld] ... // load data in rspdiv[ncoeff][nfld] struct VorDivToUV_t vordiv_to_UV = new_vordiv_to_UV(); vordiv_to_UV.rspvor = rspvor; vordiv_to_UV.rspdiv = rspdiv; vordiv_to_UV.rspu = rspu; vordiv_to_UV rspv = rspv; vordiv_to_UV.nfld = nfld; vordiv_to_UV.ncoeff = ncoeff; vordiv_to_UV.nsmax = nsmax; trans_vordiv_to_UV(&vordiv_to_UV); @endcode @note - nfld indicates the multiplicity for each variable seperately - ncoeff is equivalent to trans.nspec2 for distributed, and trans.nspec2g for global fields - nsmax indicates the spectral truncation T. */ int trans_vordiv_to_UV(struct VorDivToUV_t* vordiv_to_UV); /*! @brief Compute global spectral norms Usage:<\b> @code{.c} int nfld = 1; double* rspec = malloc( sizeof(double) * nfld*trans.nspec2 ); double* rnorm = malloc( sizeof(double) * nfld ); ... // load data in rspec[nspec2][nfld] struct SpecNorm_t specnorm = new_specnorm(&trans); specnorm.rspec = rspec; specnorm.rnorm = rnorm; specnorm.nfld = nfld; trans_specnorm(specnorm); @endcode */ int trans_specnorm(struct SpecNorm_t* specnorm); /*! @brief Remove footprint of specific resolution @param trans Trans_t struct describing specific resolution All arrays will be deallocated. */ int trans_delete(struct Trans_t* trans); /*! @brief Finalize trans library This finalizes MPI communication, and deallocates resolution-independent storage. After this, no more calls to trans should be made */ int trans_finalize(void); /*! @brief Struct that holds information to do transforms for one particular grid resolution The values ndgl, nloen, and nsmax need to be provided yourself, all other values will be defined during the trans_setup() call or trans_inquire() calls - All scalar values will be defined by trans_setup() - All array values will be allocated if needed, and defined by individual calls to trans_inquire() @note Many of these values are of no interest for normal usage */ struct Trans_t { /*! @{ @name INPUT */ int ndgl; //!< @brief Number of lattitudes int* nloen; //!< @brief Number of longitude points for each latitude \n //!< DIMENSIONS(1:NDGL) int nlon; //!< @brief Number of longitude points for all latitudes \n int nsmax; //!< @brief Spectral truncation wave number _bool llam; //!< @brief True if the corresponding resolution is LAM, false if it is global _bool lsplit; //!< @brief If false, the distribution does not allow latitudes to be split int llatlon; //!< @brief If true, the transforms compute extra coefficients for //!< latlon transforms int flt; //!< @brief If true, the Fast-Legendre-Transform method is used //!< which is faster for higher resolutions (N1024) int fft; //!< @brief FFT library to use underneith \n //!< FFT992 = 1 ; FFTW = 2 char* readfp; char* writefp; const void* cache; size_t cachesize; /*! @} */ /*! @{ @name PARALLELISATION */ int myproc; //!< @brief Current MPI task (numbering starting at 1) int nproc; //!< @brief Number of parallel MPI tasks /*! @} */ /*! @{ @name MULTI-TRANSFORMS-MANAGEMENT */ int handle; //!< @brief Resolution tag for which info is required ,default is the //!< first defined resulution (input) /*! @} */ /*! @{ @name SPECTRAL SPACE */ int nspec; //!< @brief Number of complex spectral coefficients on this PE int nspec2; //!< @brief Number of complex spectral coefficients on this PE times 2 (real and imag) int nspec2g; //!< @brief global KSPEC2 int nspec2mx; //!< @brief Maximun KSPEC2 among all PEs int nump; //!< @brief Number of spectral waves handled by this PE int ngptot; //!< @brief Total number of grid columns on this PE int ngptotg; //!< @brief Total number of grid columns on the Globe int ngptotmx; //!< @brief Maximum number of grid columns on any of the PEs int* ngptotl; //!< @brief Number of grid columns on each PE \n //!< DIMENSIONS(1:N_REGIONS_NS,1:N_REGIONS_EW) int* nmyms; //!< @brief This PEs spectral zonal wavenumbers //!< DIMENSIONS(1:NUMP) int* nasm0; //!< @brief Address in a spectral array of (m, n=m) \n //!< DIMENSIONS(0:NSMAX) int nprtrw; //!< @brief Number of processors in A-direction (input) int* numpp; //!< @brief No. of wave numbers each wave set is responsible for. \n //!< DIMENSIONS(1:NPRTRW) int* npossp; //!< @brief Defines partitioning of global spectral fields among PEs \n //!< DIMENSIONS(1:NPRTRW+1) int* nptrms; //!< @brief Pointer to the first wave number of a given a-set \n //!< DIMENSIONS(1:NPRTRW) int* nallms; //!< @brief Wave numbers for all wave-set concatenated together //!< to give all wave numbers in wave-set order \n //!< DIMENSIONS(1:NSMAX+1) int* ndim0g; //!< @brief Defines partitioning of global spectral fields among PEs \n //!< DIMENSIONS(0:NSMAX) int* nvalue; //!< @brief n value for each KSPEC2 spectral coeffient\n //!< DIMENSIONS(1:NSPEC2) /*! @} */ /*! @{ @name GRIDPOINT SPACE */ int n_regions_NS;//!< @brief Number of regions in North-South direction int n_regions_EW;//!< @brief Number of regions in East-West direction int my_region_NS;//!< @brief My region in North-South direction int my_region_EW;//!< @brief My region in East-West direction int* n_regions; //!< @brief Number of East-West Regions per band of North-South Regions //!< @brief DIMENSIONS(1:N_REGIONS_NS) int* nfrstlat; //!< @brief First latitude of each a-set in grid-point space //!< DIMENSIONS(1:N_REGIONS_NS) int* nlstlat; //!< @brief Last latitude of each a-set in grid-point space //!< DIMENSIONS(1:N_REGIONS_NS) int nfrstloff; //!< @brief Offset for first lat of own a-set in grid-point space int* nptrlat; //!< @brief Pointer to the start of each latitude //!< DIMENSIONS(1:NDGL) int* nptrfrstlat; //!< @brief Pointer to the first latitude of each a-set in //!< NSTA and NONL arrays //!< DIMENSIONS(1:N_REGIONS_NS) int* nptrlstlat; //!< @brief Pointer to the last latitude of each a-set in //!< NSTA and NONL arrays //!< DIMENSIONS(1:N_REGIONS_NS) int nptrfloff; //!< @brief Offset for pointer to the first latitude of own a-set //!< NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 int* nsta; //!< @brief Position of first grid column for the latitudes on a //!< processor. \n //!< DIMENSIONS(1:NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) //!< @details The information is available for all processors. //!< The b-sets are distinguished by the last dimension of //!< nsta(). The latitude band for each a-set is addressed by //!< nptrfrstlat(jaset),nptrlstlat(jaset), and //!< nptrfloff=nptrfrstlat(myseta) on this processors a-set. //!< Each split latitude has two entries in nsta(,:) which //!< necessitates the rather complex addressing of nsta(,:) //!< and the overdimensioning of nsta by N_REGIONS_NS. int* nonl; //!< @brief Number of grid columns for the latitudes on a processor. //!< Similar to nsta() in data structure. \n //!< DIMENSIONS(1:NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) _bool* ldsplitlat; //!< @brief True if latitude is split in grid point space over //!< two a-sets. \n //!< DIMENSIONS(1:NDGL) /*! @} */ /*! @{ @name FOURIER SPACE */ int nprtrns; //!< @brief No. of sets in N-S direction (Fourier space) //!< (always equal to NPRTRW) int* nultpp; //!< @brief Number of latitudes for which each a-set is calculating //!< the FFT's. \n //!< DIMENSIONS(1:NPRTRNS) int* nptrls; //!< @brief Pointer to first global latitude of each a-set for which //!< it performs the Fourier calculations \n //!< DIMENSIONS(1:NPRTRNS) int* nnmeng; //!< @brief associated (with NLOENG) cut-off zonal wavenumber \n //!< DIMENSIONS(1:NDGL) /*! @} */ /*! @{ @name LEGENDRE */ double* rmu; //!< @brief sin(Gaussian latitudes) \n //!< DIMENSIONS(1:NDGL) double* rgw; //!< @brief Gaussian weights \n //!< DIMENSIONS(1:NDGL) double* rpnm; //!< @brief Legendre polynomials \n //!< DIMENSIONS(1:NLEI3,1:NSPOLEGL) int nlei3; //!< @brief First dimension of Legendre polynomials int nspolegl; //!< @brief Second dimension of Legendre polynomials int* npms; //!< @brief Adress for legendre polynomial for given M (NSMAX) \n //!< DIMENSIONS(0:NSMAX) double* rlapin; //!< @brief Eigen-values of the inverse Laplace operator \n //!< DIMENSIONS(-1:NSMAX+2) int* ndglu; //!< @brief Number of active points in an hemisphere for a given wavenumber "m" \n //!< DIMENSIONS(0:NSMAX) /*! @} */ /*! @{ @name LAM */ double pexwn; //!< @brief resolution in x double peywn; //!< @brief resolution in y double * pweight; //!< @brief weight for distribution int ndgux; //!< @brief number of latitudes not in extension zone int nmsmax; //!< @brief spectral truncation in x direction int * mvalue; //!< @brief wavenumbers in x direction /*! @} */ }; /*! @brief Constructor for Trans_t, setting default values @return Trans_t struct to be used as argument for trans_setup() */ int trans_new( struct Trans_t* ); /*! @brief Set gridpoint resolution for trans @param trans [in] Trans_t used to setup @param ndgl [in] Number of lattitudes @param nloen [in] Number of longitude points for each latitude \n DIMENSIONS(1:NDGL) */ int trans_set_resol( struct Trans_t* trans, int ndgl, const int* nloen ); /*! @brief Set gridpoint resolution for trans for longitude-latitude grids @param trans [in] Trans_t used to setup @param nlon [in] Number of longitudes @param nlat [in] Number of latitudes (pole to pole) - If nlat is odd, the grid must includes poles and equator - If nlat is even, the grid must be its dual (excluding pole and equator), so points are shifted with 0.5*dx and 0.5*dy */ int trans_set_resol_lonlat( struct Trans_t* trans, int nlon, int nlat ); /*! @brief Set gridpoint resolution for trans for LAM grids @param trans [in] Trans_t used to setup @param nx [in] Number of grid points in x-direction @param ny [in] Number of grid points in y-direction @param dx [in] Grid cell size in x-direction @param dy [in] Grid cell size in y-direction */ int trans_set_resol_lam( struct Trans_t* trans, int nx, int ny, double dx, double dy ); /*! @brief Set spectral truncation wave number for trans @param trans [in] Trans_t used to setup @param nsmax [in] Spectral truncation wave number */ int trans_set_trunc( struct Trans_t* trans, int nsmax ); /*! @brief Set spectral truncation wave number for trans for LAM grids @param trans [in] Trans_t used to setup @param trunc_x [in] Spectral truncation wave number in x-direction (a.k.a. nmsmax) @param trunc_y [in] Spectral truncation wave number in y-direction (a.k.a. nsmax) */ int trans_set_trunc_lam( struct Trans_t* trans, int trunc_x, int trunc_y ); /*! @brief Arguments structure for trans_dirtrans() Use new_dirtrans() to initialise defaults for the struct (constructor) */ struct DirTrans_t { const double* rgp; //!< @brief [input] gridpoint fields //!< @details Dimensioning: rgp[#ngpblks][2*#nvordiv+#nscalar][#nproma]\n\n //!< The ordering of the output fields is as follows (all //!< parts are optional depending on the input switches): //!< - u : if #nvordiv > 0 //!< - v : if #nvordiv > 0 //!< - scalars : if #nscalar > 0 double* rspscalar; //!< @brief [output] spectral scalar valued fields //!< @details Dimensioning: rspscalar[@link Trans_t::nspec2 nspec2 @endlink][#nscalar] double* rspvor; //!< @brief [output] spectral vorticity //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] double* rspdiv; //!< @brief [output] spectral divergence //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] const double* rmeanu; //!< @brief [input] mean value of u-wind (only for LAM) //!< @details Dimensioning: rmeanu[#nvordiv] const double* rmeanv; //!< @brief [input] mean value of v-wind (only for LAM) //!< @details Dimensioning: rmeanv[#nvordiv] int nproma; //!< @brief [input,default=@link Trans_t::ngptot ngptot@endlink] Blocking factor for distributed gridpoint array int nscalar; //!< @brief [input,default=0] Number of scalar fields present in RGP int nvordiv; //!< @brief [input,default=0] Number of vorticity/divergence fields in RGP int ngpblks; //!< @brief [input,default=1] Blocking factor for distributed gridpoint array int lglobal; //!< @brief [input,default=0] rgp is a global input field --> nproma==1,ngpblks==ngptotg struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_dirtrans() }; /*! @brief Constructor for DirTrans_t, resetting default values @param trans [in] Trans_t used to set defaults @return DirTrans_t struct to be used as argument for trans_dirtrans() */ struct DirTrans_t new_dirtrans(struct Trans_t* trans); /*! @brief Arguments structure for trans_dirtrans_adj() Use new_dirtrans_adj() to initialise defaults for the struct (constructor) */ struct DirTransAdj_t { const double* rgp; //!< @brief [input] gridpoint fields //!< @details Dimensioning: rgp[#ngpblks][2*#nvordiv+#nscalar][#nproma]\n\n //!< The ordering of the output fields is as follows (all //!< parts are optional depending on the input switches): //!< - u : if #nvordiv > 0 //!< - v : if #nvordiv > 0 //!< - scalars : if #nscalar > 0 double* rspscalar; //!< @brief [output] spectral scalar valued fields //!< @details Dimensioning: rspscalar[@link Trans_t::nspec2 nspec2 @endlink][#nscalar] double* rspvor; //!< @brief [output] spectral vorticity //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] double* rspdiv; //!< @brief [output] spectral divergence //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] const double* rmeanu; //!< @brief [input] mean value of u-wind (only for LAM) //!< @details Dimensioning: rmeanu[#nvordiv] const double* rmeanv; //!< @brief [input] mean value of v-wind (only for LAM) //!< @details Dimensioning: rmeanv[#nvordiv] int nproma; //!< @brief [input,default=@link Trans_t::ngptot ngptot@endlink] Blocking factor for distributed gridpoint array int nscalar; //!< @brief [input,default=0] Number of scalar fields present in RGP int nvordiv; //!< @brief [input,default=0] Number of vorticity/divergence fields in RGP int ngpblks; //!< @brief [input,default=1] Blocking factor for distributed gridpoint array int lglobal; //!< @brief [input,default=0] rgp is a global input field --> nproma==1,ngpblks==ngptotg struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_dirtrans() }; /*! @brief Constructor for DirTransAdj_t, resetting default values @param trans [in] Trans_t used to set defaults @return DirTransAdj_t struct to be used as argument for trans_dirtrans_adj() */ struct DirTransAdj_t new_dirtrans_adj(struct Trans_t* trans); /*! @brief Arguments structure for trans_invtrans() Use new_invtrans() to initialise defaults for the struct (constructor) */ struct InvTrans_t { const double* rspscalar; //!< @brief [input,default=NULL] spectral scalar valued fields //!< @details Dimensioning: rspscalar[@link Trans_t::nspec2 nspec2 @endlink][#nscalar] const double* rspvor; //!< @brief [input] spectral vorticity //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] const double* rspdiv; //!< @brief [input] spectral divergence //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] const double* rmeanu; //!< @brief [input] mean value of u-wind (only for LAM) //!< @details Dimensioning: rmeanu[#nvordiv] const double* rmeanv; //!< @brief [input] mean value of v-wind (only for LAM) //!< @details Dimensioning: rmeanv[#nvordiv] double* rgp; //!< @brief [output] gridpoint fields //!< @details Dimensioning: rgp[#ngpblks][2*#nvordiv+#nscalar][#nproma]\n\n //!< The ordering of the output fields is as follows (all //!< parts are optional depending on the input switches): //! - vorticity : if #nvordiv > 0 and #lvordivgp true //! - divergence : if #nvordiv > 0 and #lvordivgp true //!< - u : if #nvordiv > 0 //!< - v : if #nvordiv > 0 //!< - scalars : if #nscalar > 0 //!< - N-S derivative of scalars : if #nscalar > 0 and #lscalarders true //!< - E-W derivative of u : if #nvordiv > 0 and #luvders true //!< - E-W derivative of v : if #nvordiv > 0 and #luvders true //!< - E-W derivative of scalars : if #nscalar > 0 and #lscalarders true int nproma; //!< @brief [input,default=@link Trans_t::ngptot ngptot@endlink] Blocking factor for distributed gridpoint array int nscalar; //!< @brief [input,default=0] Number of scalar fields present in RGP int nvordiv; //!< @brief [input,default=0] Number of vorticity/divergence fields in RGP int lscalarders; //!< @brief [input,default=0] Indicate if derivatives of scalars are requested int luvder_EW; //!< @brief [input,default=0] Indicate if East-West derivative of u and v is requested int lvordivgp; //!< @brief [input,default=0] Indicate if grid-point vorticity and divergence is requested int ngpblks; //!< @brief [input,default=1] Blocking factor for distributed gridpoint array int lglobal; //!< @brief [input,default=0] rgp is a global output field --> nproma==1,ngpblks==ngptotg struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_invtrans() }; /*! * @brief Constructor for InvTrans_t, resetting default values * @param trans [in] Trans_t used to set defaults * @return InvTrans_t struct to be used as argument for trans_invtrans() */ struct InvTrans_t new_invtrans(struct Trans_t* trans); //! Adjoint of spectral inverse. struct InvTransAdj_t { double* rspscalar; //!< @brief [output,default=NULL] spectral scalar valued fields //!< @details Dimensioning: rspscalar[@link Trans_t::nspec2 nspec2 @endlink][#nscalar] double* rspvor; //!< @brief [output] spectral vorticity //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] double* rspdiv; //!< @brief [output] spectral divergence //!< @details Dimensioning: rspvor[@link Trans_t::nspec2 nspec2 @endlink][#nvordiv] const double* rmeanu; //!< @brief [input] mean value of u-wind (only for LAM) //!< @details Dimensioning: rmeanu[#nvordiv] const double* rmeanv; //!< @brief [input] mean value of v-wind (only for LAM) //!< @details Dimensioning: rmeanv[#nvordiv] const double* rgp; //!< @brief [input] gridpoint fields //!< @details Dimensioning: rgp[#ngpblks][2*#nvordiv+#nscalar][#nproma]\n\n //!< The ordering of the output fields is as follows (all //!< parts are optional depending on the input switches): //! - vorticity : if #nvordiv > 0 and #lvordivgp true //! - divergence : if #nvordiv > 0 and #lvordivgp true //!< - u : if #nvordiv > 0 //!< - v : if #nvordiv > 0 //!< - scalars : if #nscalar > 0 //!< - N-S derivative of scalars : if #nscalar > 0 and #lscalarders true //!< - E-W derivative of u : if #nvordiv > 0 and #luvders true //!< - E-W derivative of v : if #nvordiv > 0 and #luvders true //!< - E-W derivative of scalars : if #nscalar > 0 and #lscalarders true int nproma; //!< @brief [input,default=@link Trans_t::ngptot ngptot@endlink] Blocking factor for distributed gridpoint array int nscalar; //!< @brief [input,default=0] Number of scalar fields present in RGP int nvordiv; //!< @brief [input,default=0] Number of vorticity/divergence fields in RGP int lscalarders; //!< @brief [input,default=0] Indicate if derivatives of scalars are requested int luvder_EW; //!< @brief [input,default=0] Indicate if East-West derivative of u and v is requested int lvordivgp; //!< @brief [input,default=0] Indicate if grid-point vorticity and divergence is requested int ngpblks; //!< @brief [input,default=1] Blocking factor for distributed gridpoint array int lglobal; //!< @brief [input,default=0] rgp is a global output field --> nproma==1,ngpblks==ngptotg struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_invtrans_adj() }; /*! * @brief Constructor for InvTransAdj_t, resetting default values * @param trans [in] Trans_t used to set defaults * @return InvTransAdj_t struct to be used as argument for trans_invtrans_adj() */ struct InvTransAdj_t new_invtrans_adj(struct Trans_t* trans); /*! @brief Arguments structure for trans_distgrid() Use new_distgrid() to initialise defaults for the struct (constructor) */ struct DistGrid_t { const double* rgpg; //!< @brief Global gridpoint array //!< Fortran DIMENSIONS(1:NGPTOTG,1:NFLDG) //!< C/C++ DIMENSIONS[NFLDG][NGPTOTG] double* rgp; //!< @brief Distributed gridpoint array //!< Fortran DIMENSIONS(1:NPROMA,1:NFLD,1:NGPBLKS) //!< C/C++ DIMENSIONS[NGPBLKS][NFDL][NPROMA] //!< Default: NPROMA=NGPTOT, NGPBLKS=1 const int* nfrom; //!< @brief Processors responsible for distributing each field //!< DIMENSIONS(1:NFLD) int nproma; //!< @brief Blocking factor for distributed gridpoint array int nfld; //!< @brief Number of distributed fields int ngpblks; //!< @brief Blocking factor for distributed gridpoint array struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_invtrans() }; /*! @brief Constructor for DistGrid_t, resetting default values @param trans [in] Trans_t used to set defaults @return DistGrid_t struct to be used as argument for trans_distgrid() */ struct DistGrid_t new_distgrid(struct Trans_t* trans); /*! @brief Arguments structure for trans_gathgrid() Use new_gathgrid() to initialise defaults for the struct (constructor) */ struct GathGrid_t { double* rgpg; //!< @brief Global gridpoint array //!< Fortran DIMENSIONS(1:NGPTOTG,1:NFLDG) //!< C/C++ DIMENSIONS[NFLDG][NGPTOTG] //!< DIMENSIONS(1:NFLDG,1:NGPTOTG) const double* rgp; //!< @brief Distributed gridpoint array //!< Fortran DIMENSIONS(1:NPROMA,1:NFLD,1:NGPBLKS) //!< C/C++ DIMENSIONS[NGPBLKS][NFDL][NPROMA] //!< Default: NPROMA=NGPTOT, NGPBLKS=1 const int* nto; //!< @brief Processors responsible for gathering each field //!< Fortran DIMENSIONS(1:NFLD) int nproma; //!< @brief Blocking factor for distributed gridpoint array int nfld; //!< @brief Number of distributed fields int ngpblks; //!< @brief Blocking factor for distributed gridpoint array struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_invtrans() }; /*! @brief Constructor for GathGrid_t, resetting default values @param trans [in] Trans_t used to set defaults @return GathGrid_t struct to be used as argument for trans_gathgrid() */ struct GathGrid_t new_gathgrid(struct Trans_t* trans); /*! @brief Arguments structure for trans_distspec() Use new_distspec() to initialise defaults for the struct (constructor) */ struct DistSpec_t { const double* rspecg; //!< @brief Global spectral array //!< Fortran DIMENSIONS(1:NFLDG,1:NSPEC2G) //!< C/C++ DIMENSIONS[NSPEC2G][NFLDG] double* rspec; //!< @brief Local spectral array //!< Fortran DIMENSIONS(1:NFLD,1:NSPEC2) //!< C/C++ DIMENSIONS[NSPEC2][NFLD] const int* nfrom; //!< @brief Processors responsible for distributing each field //!< Fortran DIMENSIONS(1:NFLD) int nfld; //!< @brief Number of distributed fields struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_invtrans() }; /*! @brief Constructor for DistSpec_t, resetting default values @param trans [in] Trans_t used to set defaults @return DistSpec_t struct to be used as argument for trans_distspec() */ struct DistSpec_t new_distspec(struct Trans_t* trans); /*! @brief Arguments structure for trans_gathspec() Use new_gathspec() to initialise defaults for the struct (constructor) */ struct GathSpec_t { double* rspecg; //!< @brief Global spectral array //!< Fortran DIMENSIONS(1:NFLDG,1:NSPEC2G) //!< C/C++ DIMENSIONS[NSPEC2G][NFLDG] const double* rspec; //!< @brief Local spectral array //!< Fortran DIMENSIONS(1:NFLD,1:NSPEC2) //!< C/C++ DIMENSIONS[NSPEC2][NFLD] const int* nto; //!< @brief Processors responsible for gathering each field //!< DIMENSIONS(1:NFLD) int nfld; //!< @brief Number of distributed fields struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_invtrans() }; /*! @brief Constructor for GathSpec_t, resetting default values @param trans [in] Trans_t used to set defaults @return GathSpec_t struct to be used as argument for trans_gathspec() */ struct GathSpec_t new_gathspec(struct Trans_t* trans); /*! @brief Arguments structure for trans_vordiv_to_UV() Use new_vordiv_to_uv() to initialise defaults for the struct (constructor) */ struct VorDivToUV_t { const double* rspvor; //!< @brief Local spectral array for vorticity //!< Fortran DIMENSIONS(1:NFLD,1:NSPEC2) //!< C/C++ DIMENSIONS[NSPEC2][NFLD] const double* rspdiv; //!< @brief Local spectral array for divergence //!< Fortran DIMENSIONS(1:NFLD,1:NSPEC2) //!< C/C++ DIMENSIONS[NSPEC2][NFLD] double* rspu; //!< @brief Local spectral array for U*cos(theta) //!< Fortran DIMENSIONS(1:NFLD,1:NSPEC2) //!< C/C++ DIMENSIONS[NSPEC2][NFLD] double* rspv; //!< @brief Local spectral array for V*cos(theta) //!< Fortran DIMENSIONS(1:NFLD,1:NSPEC2) //!< C/C++ DIMENSIONS[NSPEC2][NFLD] int nfld; //!< @brief Number of distributed fields int nsmax; //!< @brief Spectral resolution (T) int ncoeff; //!< @brief number of spectral coefficients //!< (equivalent to nspec2 for distributed or nspec2g for global) int count; //!< @brief Internal storage for calls to trans_vordiv_toUV() }; /*! @brief Constructor for VorDivToUV_t, resetting default values @return VorDivToUV_t struct to be used as argument for trans_gathspec() */ struct VorDivToUV_t new_vordiv_to_UV(void); struct SpecNorm_t { const double *rspec; //!< @brief Spectral array to compute norm of //!< Fortran DIMENSIONS(1:NFLD,1:NSPEC2) //!< C/C++ DIMENSIONS[NSPEC2][NFLD] int nmaster; //!< @brief Processor to receive norms (value 1 means MPI_RANK 0) const double *rmet; //!< @brief metric, OPTIONAL //! DIMENSIONS(0:NSMAX) double* rnorm; //!< @brief Norms (output for processor nmaster) //!< DIMENSIONS(1:NFLD) int nfld; //!< @brief Number of fields struct Trans_t* trans; //!< @brief Internal storage of trans object int count; //!< @brief Internal storage for calls to trans_invtrans() }; /*! @brief Constructor for SpecNorm_t, resetting default values @return SpecNorm_t struct to be used as argument for trans_specnorm() */ struct SpecNorm_t new_specnorm(struct Trans_t* trans); #ifdef __cplusplus } #endif #endif ectrans-1.8.0/src/transi/transi_module.F900000664000175000017500000027272415174631767020616 0ustar alastairalastair! (C) Copyright 2014- ECMWF. ! ! 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. ! !> @file trans_module.F90 !! @brief Fortran layer to trans !! !! This file contains the trans_module, !! which bridges the IFS trans library to !! the C-API !! !! @author Willem Deconinck !! @date Jul 2014 #define BOOLEAN integer(c_int) module trans_module use, intrinsic :: iso_c_binding, only: & c_ptr, & c_char, & c_int, & c_size_t, & c_float, & c_double, & c_null_ptr use, intrinsic :: iso_fortran_env, only: & output_unit, & error_unit use OML_MOD, only: & OML_MY_THREAD, & OML_GET_NUM_THREADS use MPL_module, only: & MPL_INIT, & MPL_END, & MPL_NPROC, & MPL_MYRANK, & MPL_SETDFLT_COMM, & MPL_COMM_OML, & LMPLUSERCOMM, & MPLUSERCOMM, & MPL_COMM_COMPARE use MPL_DATA_MODULE, only: & MPL_NUMPROC implicit none private :: c_ptr private :: c_char private :: c_int private :: c_size_t private :: c_float private :: c_double private :: c_null_ptr private :: output_unit private :: error_unit #if ECTRANS_HAVE_MPI private :: MPL_INIT private :: MPL_END private :: MPL_NPROC private :: MPL_MYRANK #endif public :: Trans_t public :: DirTrans_t public :: DirTransAdj_t public :: InvTrans_t public :: InvTransAdj_t public :: GathGrid_t public :: DistGrid_t public :: GathSpec_t public :: DistSpec_t public :: VorDivToUV_t public :: trans_use_mpi public :: trans_set_handles_limit public :: trans_set_radius public :: trans_set_leq_regions public :: trans_set_nprtrv public :: trans_set_nprgpew public :: trans_init public :: trans_setup public :: trans_inquire public :: trans_dirtrans public :: trans_dirtrans_adj public :: trans_invtrans public :: trans_invtrans_adj public :: trans_distgrid public :: trans_gathgrid public :: trans_distspec public :: trans_gathspec public :: trans_vordiv_to_UV public :: trans_delete public :: trans_finalize public :: allocate_ptr public :: access_ptr public :: free_ptr private #include "setup_trans0.h" #include "trans_end.h" #include "trans_release.h" #include "setup_trans.h" #include "dir_trans.h" #include "dir_transad.h" #include "inv_trans.h" #include "inv_transad.h" #include "dist_grid.h" #include "gath_grid.h" #include "dist_spec.h" #include "gath_spec.h" #include "trans_inq.h" #include "specnorm.h" #include "vordiv_to_uv.h" #if ECTRANS_HAVE_ETRANS #include "esetup_trans.h" #include "etrans_inq.h" #include "edir_trans.h" #include "edir_transad.h" #include "einv_trans.h" #include "einv_transad.h" #include "edist_grid.h" #include "egath_grid.h" #include "edist_spec.h" #include "egath_spec.h" #include "especnorm.h" #include "etrans_release.h" #endif integer, SAVE :: TRANS_MAX_HANDLES = 100 integer, SAVE :: N_REGIONS_EW integer, SAVE :: N_REGIONS_NS integer, SAVE, allocatable, target :: N_REGIONS(:) integer(c_int), SAVE :: NPRTRV = 1 integer(c_int), SAVE :: NPRGPEW = 1 real(c_double), SAVE :: RRAD = 6371.22e+03 logical, SAVE :: LEQ_REGIONS = .True. logical, SAVE :: is_init = .False. integer, SAVE :: trans_out logical, SAVE :: close_devnull #if ECTRANS_HAVE_MPI logical, SAVE :: USE_MPI = .True. #else logical, SAVE :: USE_MPI = .False. #endif integer, private, parameter :: MAX_STR_LEN = 1024 integer, parameter :: TRANS_SUCCESS = 0 integer, parameter :: TRANS_ERROR = -1 integer, parameter :: TRANS_NOTIMPL = -2 integer, parameter :: TRANS_MISSING_ARG = -3 integer, parameter :: TRANS_UNRECOGNIZED_ARG = -4 integer, parameter :: TRANS_STALE_ARG = -5 !> @brief Interface to the Trans_t struct in transi/trans.h type, bind(C) :: Trans_t ! FILL IN THESE 5 VALUES YOURSELF BEFORE callING trans_setup() */ integer(c_int) :: ndgl ! -- Number of lattitudes type(c_ptr) :: nloen ! -- Number of longitude points for each latitude ! TYPE: INTEGER(1:NDGL) integer(c_int) :: nlon ! -- Number of longitude points for all latitudes integer(c_int) :: nsmax ! -- Spectral truncation wave number BOOLEAN :: llam ! -- True if the corresponding resolution is LAM, false if it is global BOOLEAN :: lsplit integer(c_int) :: llatlon integer(c_int) :: flt integer(c_int) :: fft type(c_ptr) :: readfp; type(c_ptr) :: writefp; type(c_ptr) :: cache; integer(c_size_t) :: cachesize; ! PARALLELISATION integer(c_int) :: myproc ! -- Current MPI task (numbering starting at 1) integer(c_int) :: nproc ! -- Number of parallel MPI tasks ! MULTI-TRANSFORMS MANAGEMENT integer(c_int) :: handle ! -- Resolution tag for which info is required ,default is the ! first defined resolution (input) ! SPECTRAL SPACE integer(c_int) :: nspec ! -- Number of complex spectral coefficients on this PE integer(c_int) :: nspec2 ! -- 2*nspec integer(c_int) :: nspec2g ! -- global KSPEC2 integer(c_int) :: nspec2mx ! -- Maximun KSPEC2 among all PEs integer(c_int) :: nump ! -- Number of spectral waves handled by this PE integer(c_int) :: ngptot ! -- Total number of grid columns on this PE integer(c_int) :: ngptotg ! -- Total number of grid columns on the Globe integer(c_int) :: ngptotmx ! -- Maximum number of grid columns on any of the PEs type(c_ptr) :: ngptotl ! -- Number of grid columns one each PE ! TYPE: INTEGER(1:N_REGIONS_NS,1:N_REGIONS_EW) type(c_ptr) :: nmyms ! -- This PEs spectral zonal wavenumbers ! TYPE: INTEGER(1:NUMP) type(c_ptr) :: nasm0 ! -- Address in a spectral array of (m, n=m) ! TYPE: INTEGER(0:NSMAX) integer(c_int) :: nprtrw ! -- Number of processors in A-direction (input) type(c_ptr) :: numpp ! -- No. of wave numbers each wave set is responsible for. ! TYPE: INTEGER(1:NPRTRW) type(c_ptr) :: npossp ! -- Defines partitioning of global spectral fields among PEs ! TYPE: INTEGER(1:NPRTRW+1) type(c_ptr) :: nptrms ! -- Pointer to the first wave number of a given a-set ! TYPE: INTEGER(1:NPRTRW) type(c_ptr) :: nallms ! -- Wave numbers for all wave-set concatenated together ! to give all wave numbers in wave-set order ! TYPE: INTEGER(1:NSMAX+1) type(c_ptr) :: ndim0g ! -- Defines partitioning of global spectral fields among PEs ! TYPE: INTEGER(0:NSMAX) type(c_ptr) :: nvalue ! -- n value for each KSPEC2 spectral coeffient ! TYPE: INTEGER(1:NSPEC2) ! GRIDPOINT SPACE integer(c_int) :: n_regions_NS ! integer(c_int) :: n_regions_EW ! integer(c_int) :: my_region_NS ! integer(c_int) :: my_region_EW ! type(c_ptr) :: n_regions ! -- Number of East-West Regions per band of North-South Regions type(c_ptr) :: nfrstlat ! -- First latitude of each a-set in grid-point space ! TYPE: INTEGER(1:N_REGIONS_NS) type(c_ptr) :: nlstlat ! -- Last latitude of each a-set in grid-point space ! TYPE: INTEGER(1:N_REGIONS_NS) integer(c_int) :: nfrstloff ! -- Offset for first lat of own a-set in grid-point space type(c_ptr) :: nptrlat ! -- Pointer to the start of each latitude ! TYPE: INTEGER(1:NDGL) type(c_ptr) :: nptrfrstlat ! -- Pointer to the first latitude of each a-set in ! NSTA and NONL arrays ! TYPE: INTEGER(1:N_REGIONS_NS) type(c_ptr) :: nptrlstlat ! -- Pointer to the last latitude of each a-set in ! NSTA and NONL arrays ! TYPE: INTEGER(1:N_REGIONS_NS) integer(c_int) :: nptrfloff ! -- Offset for pointer to the first latitude of own a-set ! NSTA and NONL arrays, i.e. nptrfrstlat(myseta)-1 type(c_ptr) :: nsta ! -- Position of first grid column for the latitudes on a ! processor. The information is available for all processors. ! The b-sets are distinguished by the last dimension of ! nsta(). The latitude band for each a-set is addressed by ! nptrfrstlat(jaset),nptrlstlat(jaset), and ! nptrfloff=nptrfrstlat(myseta) on this processors a-set. ! Each split latitude has two entries in nsta(,:) which ! necessitates the rather complex addressing of nsta(,:) ! and the overdimensioning of nsta by N_REGIONS_NS. ! TYPE: INTEGER(1:NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) type(c_ptr) :: nonl ! -- Number of grid columns for the latitudes on a processor. ! Similar to nsta() in data structure. ! TYPE: INTEGER(1:NDGL+N_REGIONS_NS-1,1:N_REGIONS_EW) type(c_ptr) :: ldsplitlat ! -- True if latitude is split in grid point space over ! two a-sets. ! TYPE: BOOLEAN(1:NDGL) (BOOLEAN=c_int) ! FOURIER SPACE integer(c_int) :: nprtrns ! -- No. of sets in N-S direction (Fourier space) ! (always equal to NPRTRW) type(c_ptr) :: nultpp ! -- Number of latitudes for which each a-set is calculating ! the FFT's. ! TYPE: INTEGER(1:NPRTRNS) type(c_ptr) :: nptrls ! -- Pointer to first global latitude of each a-set for which ! it performs the Fourier calculations ! TYPE: INTEGER(1:NPRTRNS) type(c_ptr) :: nnmeng ! -- associated (with NLOENG) cut-off zonal wavenumber ! TYPE: INTEGER(1:NDGL) ! LEGENDRE type(c_ptr) :: rmu ! -- sin(Gaussian latitudes) ! TYPE: REAL(1:NDGL) type(c_ptr) :: rgw ! -- Gaussian weights ! TYPE: REAL(1:NDGL) type(c_ptr) :: rpnm ! -- Legendre polynomials ! TYPE: REAL(1:NLEI3,1:NSPOLEGL) integer(c_int) :: nlei3 ! -- First dimension of Legendre polynomials integer(c_int) :: nspolegl ! -- Second dimension of Legendre polynomials type(c_ptr) :: npms ! -- Adress for legendre polynomial for given M (NSMAX) ! TYPE: INTEGER(0:NSMAX) type(c_ptr) :: rlapin ! -- Eigen-values of the inverse Laplace operator ! TYPE: REAL(-1:NSMAX+2) type(c_ptr) :: ndglu ! -- Number of active points in an hemisphere for a given wavenumber "m" ! TYPE: INTEGER(0:NSMAX) ! LAM specific properties real(c_double) :: pexwn ! resolution in x real(c_double) :: peywn ! resolution in y type(c_ptr) :: pweight ! weight for distribution integer(c_int) :: ndgux ! number of latitudes not in extension zone integer(c_int) :: nmsmax ! spectral truncation in x direction type(c_ptr) :: mvalue ! wavenumbers in x direction end type Trans_t type, bind(C) :: DirTrans_t type(c_ptr) :: rgp type(c_ptr) :: rspscalar type(c_ptr) :: rspvor type(c_ptr) :: rspdiv type(c_ptr) :: rmeanu type(c_ptr) :: rmeanv integer(c_int) :: nproma integer(c_int) :: nscalar integer(c_int) :: nvordiv integer(c_int) :: ngpblks integer(c_int) :: lglobal type(c_ptr) :: trans integer(c_int) :: count end type DirTrans_t type, bind(C) :: DirTransAdj_t type(c_ptr) :: rgp type(c_ptr) :: rspscalar type(c_ptr) :: rspvor type(c_ptr) :: rspdiv type(c_ptr) :: rmeanu type(c_ptr) :: rmeanv integer(c_int) :: nproma integer(c_int) :: nscalar integer(c_int) :: nvordiv integer(c_int) :: ngpblks integer(c_int) :: lglobal type(c_ptr) :: trans integer(c_int) :: count end type DirTransAdj_t type, bind(C) :: InvTrans_t type(c_ptr) :: rspscalar type(c_ptr) :: rspvor type(c_ptr) :: rspdiv type(c_ptr) :: rmeanu type(c_ptr) :: rmeanv type(c_ptr) :: rgp integer(c_int) :: nproma integer(c_int) :: nscalar integer(c_int) :: nvordiv integer(c_int) :: lscalarders integer(c_int) :: luvder_EW integer(c_int) :: lvordivgp integer(c_int) :: ngpblks integer(c_int) :: lglobal type(c_ptr) :: trans integer(c_int) :: count end type InvTrans_t type, bind(C) :: InvTransAdj_t type(c_ptr) :: rspscalar type(c_ptr) :: rspvor type(c_ptr) :: rspdiv type(c_ptr) :: rmeanu type(c_ptr) :: rmeanv type(c_ptr) :: rgp integer(c_int) :: nproma integer(c_int) :: nscalar integer(c_int) :: nvordiv integer(c_int) :: lscalarders integer(c_int) :: luvder_EW integer(c_int) :: lvordivgp integer(c_int) :: ngpblks integer(c_int) :: lglobal type(c_ptr) :: trans integer(c_int) :: count end type InvTransAdj_t type, bind(C) :: DistGrid_t type(c_ptr) :: rgpg type(c_ptr) :: rgp type(c_ptr) :: nfrom integer(c_int) :: nproma integer(c_int) :: nfld integer(c_int) :: ngpblks type(c_ptr) :: trans integer(c_int) :: count end type DistGrid_t type, bind(C) :: GathGrid_t type(c_ptr) :: rgpg type(c_ptr) :: rgp type(c_ptr) :: nto integer(c_int) :: nproma integer(c_int) :: nfld integer(c_int) :: ngpblks type(c_ptr) :: trans integer(c_int) :: count end type GathGrid_t type, bind(C) :: DistSpec_t type(c_ptr) :: rspecg type(c_ptr) :: rspec type(c_ptr) :: nfrom integer(c_int) :: nfld type(c_ptr) :: trans integer(c_int) :: count end type DistSpec_t type, bind(C) :: GathSpec_t type(c_ptr) :: rspecg type(c_ptr) :: rspec type(c_ptr) :: nto integer(c_int) :: nfld type(c_ptr) :: trans integer(c_int) :: count end type GathSpec_t type, bind(C) :: VorDivToUV_t type(c_ptr) :: rspvor type(c_ptr) :: rspdiv type(c_ptr) :: rspu type(c_ptr) :: rspv integer(c_int) :: nfld integer(c_int) :: nsmax integer(c_int) :: ncoeff integer(c_int) :: count end type VorDivToUV_t type, bind(C) :: SpecNorm_t type(c_ptr) :: rspec integer(c_int) :: nmaster type(c_ptr) :: rmet type(c_ptr) :: rnorm integer(c_int) :: nfld type(c_ptr) :: trans integer(c_int) :: count end type SpecNorm_t interface subroutine transi_malloc_bool(ptr,len) bind(C,name="transi_malloc_bool") use, intrinsic :: iso_c_binding, only: c_ptr, c_int type(c_ptr) :: ptr integer(c_int), value :: len end subroutine transi_malloc_bool subroutine transi_malloc_int(ptr,len) bind(C,name="transi_malloc_int") use, intrinsic :: iso_c_binding, only: c_ptr, c_int type(c_ptr) :: ptr integer(c_int), value :: len end subroutine transi_malloc_int subroutine transi_malloc_float(ptr,len) bind(C,name="transi_malloc_float") use, intrinsic :: iso_c_binding, only: c_ptr, c_int type(c_ptr) :: ptr integer(c_int), value :: len end subroutine transi_malloc_float subroutine transi_malloc_double(ptr,len) bind(C,name="transi_malloc_double") use, intrinsic :: iso_c_binding, only: c_ptr, c_int type(c_ptr) :: ptr integer(c_int), value :: len end subroutine transi_malloc_double subroutine transi_free(ptr) bind(C,name="transi_free") use, intrinsic :: iso_c_binding, only: c_ptr type(c_ptr), intent(in) :: ptr end subroutine transi_free subroutine transi_disable_DR_HOOK_ASSERT_MPI_INITIALIZED() bind(C, & & name="transi_disable_DR_HOOK_ASSERT_MPI_INITIALIZED") end subroutine end interface interface trans_inquire module procedure trans_inquire_cstr module procedure trans_inquire_fstr end interface trans_inquire interface allocate_ptr ! module procedure allocate_bool1_ptr module procedure allocate_int1_ptr module procedure allocate_int2_ptr module procedure allocate_double1_ptr module procedure allocate_double2_ptr end interface allocate_ptr interface access_ptr ! module procedure allocate_bool1_ptr module procedure allocate_int1_ptr module procedure allocate_int2_ptr module procedure allocate_double1_ptr module procedure allocate_double2_ptr end interface access_ptr contains function is_lam(trans) logical :: is_lam type(Trans_t), intent(in) :: trans is_lam = trans%llam /= 0 end function ! ============================================================================= ! From fckit_c_interop module function c_str_to_string(s) result(string) use, intrinsic :: iso_c_binding character(kind=c_char,len=1), intent(in) :: s(*) character(len=:), allocatable :: string integer :: i, nchars i = 1 do if (s(i) == c_null_char) exit i = i + 1 enddo nchars = i - 1 ! Exclude null character from Fortran string allocate(character(len=nchars) :: string) do i=1,nchars string(i:i) = s(i) enddo end function function c_ptr_to_string(cptr) result(string) use, intrinsic :: iso_c_binding type(c_ptr), intent(in) :: cptr character(kind=c_char,len=:), allocatable :: string character, pointer :: s(:) call c_f_pointer ( cptr , s, (/MAX_STR_LEN/) ) string = c_str_to_string(s) end function ! ============================================================================= subroutine to_lower(str) character(*), intent(inout) :: str integer :: i do i = 1, len(str) select case(str(i:i)) case("A":"Z") str(i:i) = achar(iachar(str(i:i))+32) end select end do end subroutine to_lower subroutine transi_error(err_msg) character(len=*), intent(in) :: err_msg write(error_unit,'(A)') err_msg end subroutine function trans_set_handles_limit(limit) bind(C,name="trans_set_handles_limit") integer(c_int) :: trans_set_handles_limit integer(c_int), value, intent(in) :: limit TRANS_MAX_HANDLES = limit trans_set_handles_limit = TRANS_SUCCESS end function function trans_set_radius(radius) bind(C,name="trans_set_radius") integer(c_int) :: trans_set_radius real(c_double), value, intent(in) :: radius RRAD = radius trans_set_radius = TRANS_SUCCESS end function function trans_set_leq_regions(ldeq_regions) bind(C,name="trans_set_leq_regions") integer(c_int) :: trans_set_leq_regions BOOLEAN, value, intent(in) :: ldeq_regions LEQ_REGIONS = ldeq_regions /= 0 trans_set_leq_regions = TRANS_SUCCESS end function function trans_set_nprtrv(kprtrv) bind(C,name="trans_set_nprtrv") integer(c_int) :: trans_set_nprtrv integer(c_int), value, intent(in) :: kprtrv NPRTRV = kprtrv trans_set_nprtrv = TRANS_SUCCESS end function function trans_set_nprgpew(kprgpew) bind(C,name="trans_set_nprgpew") integer(c_int) :: trans_set_nprgpew integer(c_int), value, intent(in) :: kprgpew ! only possible before trans_init if ( .not. is_init ) then NPRGPEW = kprgpew else if(NPRGPEW /= KPRGPEW) then write(error_unit,'(2A,I0,A)') "trans_set_nprgpew: Must be called before trans_init," ,& & "and may not be modified later (nprgpew=",NPRGPEW,")" trans_set_nprgpew = TRANS_ERROR return endif endif trans_set_nprgpew = TRANS_SUCCESS end function function trans_use_mpi(lmpi) bind(C,name="trans_use_mpi") integer(c_int) :: trans_use_mpi integer(c_int), value, intent(in) :: lmpi #if ECTRANS_HAVE_MPI if( lmpi == 0 ) then USE_MPI = .False. else USE_MPI = .True. endif #endif trans_use_mpi = TRANS_SUCCESS end function function devnull(opened) integer :: devnull logical, intent(out), optional :: opened integer :: devnull_unit inquire(file="/dev/null", number=devnull_unit) if( devnull_unit == 5 ) devnull_unit = -1 ! Willem D: Bug in gfortran and openmpi if( devnull_unit == -1 ) then devnull_unit = 777 open( unit=devnull_unit, file="/dev/null" ) if( present(opened) ) opened = .true. else if( present(opened) ) opened = .false. endif devnull = devnull_unit end function function trans_init() bind(C,name="trans_init") result(iret) integer(c_int) :: iret integer :: NPRTRW, NPRGPNS integer, allocatable :: I_REGIONS(:) logical :: LMPOFF LMPOFF = .not. USE_MPI trans_out = devnull( opened=close_devnull ) if( USE_MPI ) then call MPL_INIT(KOUTPUT=0,KUNIT=trans_out,LDINFO=.False.) allocate( I_REGIONS(MPL_NPROC()) ) NPRGPNS = MPL_NPROC()/NPRGPEW NPRTRW = MPL_NPROC()/NPRTRV; else call transi_disable_DR_HOOK_ASSERT_MPI_INITIALIZED() allocate( I_REGIONS(1) ) NPRGPNS = 1 NPRGPEW = 1 NPRTRW = 1 endif call SETUP_TRANS0(KOUT=trans_out, KERR=error_unit, KPRINTLEV=0, KMAX_RESOL=TRANS_MAX_HANDLES,& & KPRTRW=NPRTRW, LDEQ_REGIONS=LEQ_REGIONS, KPRGPNS=NPRGPNS, KPRGPEW=NPRGPEW,& & PRAD=RRAD, K_REGIONS_NS=N_REGIONS_NS, K_REGIONS_EW=N_REGIONS_EW, K_REGIONS=I_REGIONS,& & LDMPOFF=LMPOFF ) allocate(N_REGIONS(1:N_REGIONS_NS)) N_REGIONS(1:N_REGIONS_NS)=I_REGIONS(1:N_REGIONS_NS) is_init = .True. iret = TRANS_SUCCESS end function trans_init function trans_set_mpi_comm(mpi_user_comm) bind(C,name="trans_set_mpi_comm") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret integer(c_int), value, intent(in) :: mpi_user_comm integer :: dummy_comm integer(c_int) :: MPL_COMM_COMPARE_RESULT, MPL_COMM_COMPARE_ERROR iret = TRANS_SUCCESS if (.not. USE_MPI) return ! Confirm that this is called prior to trans_init, to ensure correct setting of global vars. ! ! If it is the case that trans_init has been called prior, ensure the comm here is the same ! as what has been setup previously. if (.not. is_init) then ! MPL not yet initialised. if (MPL_NUMPROC == -1) then ! Set LMPLUSERCOMM and MPLUSERCOMM to be used in MPL_INIT when trans_init() is called LMPLUSERCOMM = .TRUE. MPLUSERCOMM = mpi_user_comm else call MPL_SETDFLT_COMM(mpi_user_comm, dummy_comm) end if else ! Trans already initialised. If it has already been setup with the requested communicator ! then there is no issue. Otherwise, the user is attempting to change the comm ! mid-run which is not supported. if (size(MPL_COMM_OML) < OML_GET_NUM_THREADS()) then write(error_unit,'(A,I0,A,I0)') "trans_set_mpi_comm: ERROR: Mismatch in number of OML & & MPI comms in MPL: size ", size(MPL_COMM_OML), & "should be = ", OML_GET_NUM_THREADS() iret = TRANS_ERROR return end if CALL MPL_COMM_COMPARE(mpi_user_comm, MPL_COMM_OML(OML_MY_THREAD()), MPL_COMM_COMPARE_RESULT, MPL_COMM_COMPARE_ERROR) IF (MPL_COMM_COMPARE_ERROR /= 0 .OR. MPL_COMM_COMPARE_RESULT > 1) THEN ! The communicators are not identical (MPL_COMM_COMPARE_RESULT=0) and not congruent (MPL_COMM_COMPARE_RESULT=1) write(error_unit,'(A)') "trans_set_mpi_comm: ERROR:& & trans_set_mpi_comm must be called prior to trans_init." write(error_unit,'(A,I0,A)') " & & Previously initialised with a different MPI communicator (",MPL_COMM_OML(OML_MY_THREAD()),")" write(error_unit,'(A,I0,A)') " & & Changing the communicator mid-run to a non-congruent one (",mpi_user_comm,") is not supported." iret = TRANS_ERROR return end if end if end function trans_set_mpi_comm function trans_setup(trans) bind(C,name="trans_setup") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(Trans_t), intent(inout) :: trans integer(c_int), pointer :: nloen(:) integer(c_int), pointer :: n_regions_fptr(:) logical, parameter :: lkeeprpnm =.False. logical, parameter :: luserpnm =.False. ! Don't use Belusov algorithm (uses twice the memory) logical :: llam ! input logical :: lgridonly, lsplit !input logical :: lspeconly ! only logical :: llatlon ! input logical :: llatlonshift ! input integer(c_int) :: nlon integer(c_int) :: err character(len=MAX_STR_LEN) :: readfp, writefp logical :: luseflt BOOLEAN :: lleq_regions integer :: jgl real(c_double), pointer :: pweight(:) ! resolution-dependent defaults if (trans%ndgux<0) trans%ndgux=trans%ndgl iret = TRANS_SUCCESS lsplit = .False. if( trans%lsplit /= 0 ) lsplit = .True. llam = is_lam(trans) llatlon = .False. llatlonshift = .False. if( trans%llatlon /= 0 ) llatlon = .True. if( trans%llatlon == 2 ) llatlonshift = .True. #ifdef ECTRANS_GPU_VERSION if (llatlon) then call transi_error("trans_setup: ERROR: lonlat grid input not (yet) implemented for GPU") trans%handle = 0 ! Not created! iret = TRANS_NOTIMPL return endif #endif if ( .not. is_init ) then ! default for lam is without leq_regions if( llam ) then lleq_regions = 0 ! .false. err = trans_set_leq_regions(lleq_regions) endif err = trans_init() endif lspeconly = .False. if( trans%ndgl < 0 .and. trans%nlon < 0 ) then lspeconly = .true. trans%ndgl = 2 endif nlon = trans%nlon if( nlon < 0 .and. trans%ndgl >= 0 ) then if( c_associated( trans%nloen ) ) then call c_f_pointer( trans%nloen, nloen, (/trans%ndgl/) ) nlon = nloen(1) else nlon = 2*trans%ndgl endif endif lgridonly = .False. if( trans%nsmax < 0 ) then lgridonly = .true. endif if( lgridonly .and. lspeconly ) then write(error_unit,'(A)') "trans_setup: ERROR: Cannot setup with both lgridonly and lspeconly. Make up your mind." iret = TRANS_ERROR return endif writefp="" if( c_associated(trans%writefp) ) then writefp = c_ptr_to_string(trans%writefp) !call cptr_to_f_string(trans%writefp,writefp) endif readfp="" if( c_associated(trans%readfp) ) then readfp = c_ptr_to_string(trans%readfp) !call cptr_to_f_string(trans%readfp,readfp) endif if ( trans%cachesize > 0 ) then if( .not. c_associated( trans%cache ) ) then write(error_unit,'(A)') "Cache memory was not allocated" iret = TRANS_MISSING_ARG return endif endif #define LATLON_FLAGS LDLL=llatlon, LDSHIFTLL=llatlonshift, if( .not. llam ) then ! if( trans%flt > 0 .and. trans%nsmax+1 > trans%ndgl ) then ! write(error_unit,'(A)') "trans_setup: WARNING: A bug in trans doesn't allow to use FLT with "& ! & // "truncation (nsmax+1) > nb_latitudes (ndgl). Continuing with FLT=OFF." ! endif ! if( trans%nsmax+1 > trans%ndgl ) then ! trans%flt = 0 ! endif luseflt = .False. if( trans%flt > 0 ) luseflt = .True. if( .not. c_associated( trans%nloen ) ) then ! Setup that involves latlon requires no nloen if( len_trim(readfp) > 0 ) then if( trans%flt >= 0 ) then ! LONLAT; Impose FLT; READ coeffs from file call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon, & & CDIO_LEGPOL="readf", & & CDLEGPOLFNAME=readfp, & & LDUSEFLT=luseflt ) else ! LONLAT; Default FLT; READ coeffs from file call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon, & & CDIO_LEGPOL="readf", & & CDLEGPOLFNAME=readfp ) endif elseif( len_trim(writefp) > 0 ) then if( trans%flt >= 0 ) then ! LONLAT; Impose FLT; WRITE coeffs to file call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon, & & CDIO_LEGPOL="writef", & & CDLEGPOLFNAME=writefp, & & LDUSEFLT=luseflt ) else ! LONLAT; Impose FLT; WRITE coeffs to file call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon, & & CDIO_LEGPOL="writef", & & CDLEGPOLFNAME=writefp ) endif elseif( trans%cachesize > 0 ) then if( trans%flt >= 0 ) then ! LONLAT; Impose FLT; read CACHED coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon, & & CDIO_LEGPOL="membuf", & & KLEGPOLPTR=trans%cache, & & KLEGPOLPTR_LEN=trans%cachesize, & & LDUSEFLT=luseflt ) else ! LONLAT; Default FLT; read CACHED coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon, & & CDIO_LEGPOL="membuf", & & KLEGPOLPTR=trans%cache, & & KLEGPOLPTR_LEN=trans%cachesize ) endif else if( trans%flt >= 0 ) then ! LONLAT; Impose FLT call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon, & & LDUSEFLT=luseflt ) else ! LONLAT; Default FLT call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KDLON=nlon ) endif endif else ! we have nloen call c_f_pointer( trans%nloen, nloen, (/trans%ndgl/) ) if( len_trim(readfp) > 0 ) then if( trans%flt >= 0 ) then ! REDUCEDGAUSSIANGRID; Impose FLT; READ coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen, CDIO_LEGPOL="readf", & & CDLEGPOLFNAME=trim(readfp),& & LDUSEFLT=luseflt ) else ! REDUCEDGAUSSIANGRID; Default FLT; READ coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen, CDIO_LEGPOL="readf", & & CDLEGPOLFNAME=trim(readfp) ) endif elseif( len_trim(writefp) > 0 ) then if( trans%flt >= 0 ) then ! REDUCEDGAUSSIANGRID; Impose FLT; WRITE coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen, & & CDIO_LEGPOL="writef", & & CDLEGPOLFNAME=trim(writefp), & & LDUSEFLT=luseflt ) else ! REDUCEDGAUSSIANGRID; Default FLT; READ coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen, & & CDIO_LEGPOL="writef", & & CDLEGPOLFNAME=trim(writefp) ) endif elseif( trans%cachesize > 0 ) then if( trans%flt >= 0 ) then ! REDUCEDGAUSSIANGRID; Default FLT; read CACHED coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen, & & CDIO_LEGPOL="membuf", & & KLEGPOLPTR=trans%cache, & & KLEGPOLPTR_LEN=trans%cachesize, & & LDUSEFLT=luseflt ) else ! REDUCEDGAUSSIANGRID; Impose FLT; read CACHED coefficients call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen, & & CDIO_LEGPOL="membuf", & & KLEGPOLPTR=trans%cache, & & KLEGPOLPTR_LEN=trans%cachesize ) endif else if( trans%flt >= 0 ) then ! REDUCEDGAUSSIANGRID; Impose FLT call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen, & & LDUSEFLT=luseflt ) else ! REDUCEDGAUSSIANGRID; Default FLT call SETUP_TRANS( LATLON_FLAGS & & KSMAX=trans%nsmax, & & KRESOL=trans%handle, & & KDGL=trans%ndgl, & & LDGRIDONLY=LGRIDONLY, & & LDSPSETUPONLY=LSPECONLY, & & LDSPLIT=LSPLIT, & & LDKEEPRPNM=LKEEPRPNM, & & LDUSERPNM=LUSERPNM, & & KLOEN=nloen ) endif endif endif else ! llam #if ECTRANS_HAVE_ETRANS if (trans%nmsmax < 0 .and. .not. lgridonly) then call transi_error("trans_setup: ERROR: nmsmax < 0") iret=TRANS_ERROR return endif ! ESETUP_TRANS does not have LDSPSETUPONLY, so add the grid resolution here if (lspeconly) then trans%nlon = trans%nmsmax * 2 + 1 trans%ndgl = trans%nsmax * 2 + 1 endif ! set resolution-dependent defaults if (trans%ndgux<0) trans%ndgux=trans%ndgl ! nloen is constant for lam call allocate_ptr( trans%nloen, trans%ndgl, nloen ) nloen(:)=trans%nlon if ( .not. c_associated( trans%pweight ) ) then ! etrans setup without pweight call ESETUP_TRANS( & KMSMAX = trans%nmsmax, & KSMAX = trans%nsmax, & KDGL = trans%ndgl, & KDGUX = trans%ndgux, & KLOEN = nloen, & LDSPLIT = lsplit, & KRESOL = trans%handle, & PEXWN = trans%pexwn, & PEYWN = trans%peywn, & LDGRIDONLY = lgridonly) else ! etrans setup with pweight call c_f_pointer( trans%pweight, pweight, (/trans%ndgl*trans%nlon/) ) call ESETUP_TRANS( & KMSMAX = trans%nmsmax, & KSMAX = trans%nsmax, & KDGL = trans%ndgl, & KDGUX = trans%ndgux, & KLOEN = nloen, & LDSPLIT = lsplit, & KRESOL = trans%handle, & PEXWN = trans%pexwn, & PEYWN = trans%peywn, & PWEIGHT = pweight, & LDGRIDONLY = lgridonly) endif #else call transi_error("trans_setup: ERROR: llam = true requires etrans") iret = TRANS_ERROR return #endif endif if( USE_MPI ) then trans%myproc = MPL_MYRANK() trans%nproc = MPL_NPROC() else trans%myproc = 1 trans%nproc = 1 endif trans%n_regions_NS = N_REGIONS_NS trans%n_regions_EW = N_REGIONS_EW if( .not. is_lam(trans) ) then call TRANS_INQ( KRESOL = trans%handle, & KMY_REGION_NS = trans%my_region_NS, & KMY_REGION_EW = trans%my_region_EW, & KSPEC = trans%nspec, & KSPEC2 = trans%nspec2, & KSPEC2G = trans%nspec2g, & KSPEC2MX = trans%nspec2mx, & KNUMP = trans%nump, & KGPTOT = trans%ngptot, & KGPTOTG = trans%ngptotg, & KGPTOTMX = trans%ngptotmx, & KFRSTLOFF = trans%nfrstloff, & KPTRFLOFF = trans%nptrfloff, & KPRTRW = trans%nprtrw, & KLEI3 = trans%nlei3, & KSPOLEGL = trans%nspolegl, & LDLAM = llam & ) if( trans%llatlon == 1 ) trans%ngptotg = trans%ngptotg-nlon #if ECTRANS_HAVE_ETRANS else call ETRANS_INQ( KRESOL = trans%handle, & KSPEC = trans%nspec, & KSPEC2 = trans%nspec2, & KSPEC2G = trans%nspec2g, & KSPEC2MX = trans%nspec2mx, & KNUMP = trans%nump, & KGPTOT = trans%ngptot, & KGPTOTG = trans%ngptotg, & KGPTOTMX = trans%ngptotmx, & KFRSTLOFF = trans%nfrstloff, & KPTRFLOFF = trans%nptrfloff, & KPRTRW = trans%nprtrw, & KMY_REGION_NS = trans%my_region_NS, & KMY_REGION_EW = trans%my_region_EW, & KLEI3 = trans%nlei3, & KSPOLEGL = trans%nspolegl) #endif endif trans%nprtrns = trans%nprtrw trans%ngptotl = C_NULL_PTR trans%nmyms = C_NULL_PTR trans%nasm0 = C_NULL_PTR trans%numpp = C_NULL_PTR trans%npossp = C_NULL_PTR trans%nptrms = C_NULL_PTR trans%nallms = C_NULL_PTR trans%ndim0g = C_NULL_PTR trans%n_regions = C_NULL_PTR trans%nfrstlat = C_NULL_PTR trans%nlstlat = C_NULL_PTR trans%nptrlat = C_NULL_PTR trans%nptrfrstlat = C_NULL_PTR trans%nptrlstlat = C_NULL_PTR trans%nsta = C_NULL_PTR trans%nonl = C_NULL_PTR trans%nultpp = C_NULL_PTR trans%nptrls = C_NULL_PTR trans%nnmeng = C_NULL_PTR trans%rmu = C_NULL_PTR trans%rgw = C_NULL_PTR trans%rpnm = C_NULL_PTR trans%npms = C_NULL_PTR trans%ndglu = C_NULL_PTR trans%rlapin = C_NULL_PTR trans%nvalue = C_NULL_PTR trans%mvalue = C_NULL_PTR trans%ldsplitlat = C_NULL_PTR call allocate_ptr( trans%n_regions,N_REGIONS_NS, n_regions_fptr ) n_regions_fptr(:) = N_REGIONS(:) end function trans_setup function trans_inquire_cstr(trans,vars) bind(C,name="trans_inquire") result(iret) integer(c_int) :: iret type(Trans_t), intent(inout) :: trans character(len=1,kind=c_char), dimension(*), intent(in) :: vars character(len=MAX_STR_LEN,kind=c_char) :: vars_fstr vars_fstr = c_str_to_string(vars) iret = trans_inquire_fstr(trans,vars_fstr) end function trans_inquire_cstr function trans_inquire_fstr(trans,vars_fstr) result(iret) integer(c_int) :: iret type(Trans_t), intent(inout) :: trans character(len=*), intent(in) :: vars_fstr character(20) :: var_arr(30), var integer :: nvars, jvar !logical(c_bool), pointer :: bool1(:) integer(c_int), pointer :: int1(:), int2(:,:) real(c_double), pointer :: double1(:), double2(:,:) !logical, allocatable :: booltmp(:) nvars = count(transfer(vars_fstr, 'a', len(vars_fstr)) == ",") + 1 read(vars_fstr, *) var_arr(1:nvars) do jvar=1,nvars var = trim(var_arr(jvar)) call to_lower(var) if ( var == "numpp" ) then call allocate_ptr( trans%numpp, trans%nprtrw, int1 ) call TRANS_INQ( KRESOL=trans%handle, KUMPP=int1 ) elseif( var == "ngptotl" ) then call allocate_ptr( trans%ngptotl, trans%n_regions_NS, trans%n_regions_EW, int2 ) call TRANS_INQ( KRESOL=trans%handle, KGPTOTL=int2 ) elseif( var == "nmyms" ) then call allocate_ptr( trans%nmyms, trans%nump, int1 ) call TRANS_INQ( KRESOL=trans%handle, KMYMS=int1 ) elseif( var == "nasm0" ) then call allocate_ptr( trans%nasm0, trans%nsmax+1, int1 ) call TRANS_INQ( KRESOL=trans%handle, KASM0=int1 ) elseif( var == "npossp" ) then call allocate_ptr( trans%npossp, trans%nprtrw+1, int1 ) call TRANS_INQ( KRESOL=trans%handle, KPOSSP=int1 ) elseif( var == "nptrms" ) then call allocate_ptr( trans%nptrms, trans%nprtrw, int1 ) call TRANS_INQ( KRESOL=trans%handle, KPTRMS=int1 ) elseif( var == "nallms" ) then call allocate_ptr( trans%nallms, trans%nsmax+1, int1 ) call TRANS_INQ( KRESOL=trans%handle, KALLMS=int1 ) elseif( var == "ndim0g" ) then call allocate_ptr( trans%ndim0g, trans%nsmax+1, int1 ) call TRANS_INQ( KRESOL=trans%handle, KDIM0G=int1 ) elseif( var == "nvalue" ) then call allocate_ptr( trans%nvalue, trans%nspec2, int1 ) call TRANS_INQ( KRESOL=trans%handle, KNVALUE=int1 ) if( .not. is_lam(trans) ) then call TRANS_INQ( KRESOL=trans%handle, KNVALUE=int1 ) #if ECTRANS_HAVE_ETRANS else call ETRANS_INQ( KRESOL=trans%handle, KNVALUE=int1 ) #endif endif #if ECTRANS_HAVE_ETRANS elseif( var == "mvalue" ) then call allocate_ptr( trans%mvalue, trans%nspec2, int1 ) call ETRANS_INQ( KRESOL=trans%handle, KMVALUE=int1 ) #endif elseif( var == "nfrstlat" ) then call allocate_ptr( trans%nfrstlat, trans%n_regions_NS, int1 ) call TRANS_INQ( KRESOL=trans%handle, KFRSTLAT=int1 ) elseif( var == "nlstlat" ) then call allocate_ptr( trans%nlstlat, trans%n_regions_NS, int1 ) call TRANS_INQ( KRESOL=trans%handle, KLSTLAT=int1 ) elseif( var == "nptrlat" ) then call allocate_ptr( trans%nptrlat, trans%ndgl, int1 ) call TRANS_INQ( KRESOL=trans%handle, KPTRLAT=int1 ) elseif( var == "nptrfrstlat" ) then call allocate_ptr( trans%nptrfrstlat ,trans%n_regions_ns, int1 ) call TRANS_INQ( KRESOL=trans%handle, KPTRFRSTLAT=int1 ) elseif( var == "nptrlstlat" ) then call allocate_ptr( trans%nptrlstlat, trans%n_regions_ns, int1 ) call TRANS_INQ( KRESOL=trans%handle, KPTRLSTLAT=int1 ) elseif( var == "nsta" ) then call allocate_ptr( trans%nsta, trans%ndgl+trans%n_regions_NS-1, trans%n_regions_EW, int2 ) call TRANS_INQ( KRESOL=trans%handle, KSTA=int2 ) elseif( var == "nonl" ) then call allocate_ptr( trans%nonl, trans%ndgl+trans%n_regions_NS-1, trans%n_regions_EW, int2 ) call TRANS_INQ( KRESOL=trans%handle, KONL=int2 ) elseif( var == "ldsplitlat" ) then !!call allocate_ptr( trans%nonl, trans%ndgl, bool1 ) !allocate( booltmp(trans%ndgl) ) !call TRANS_INQ( KRESOL=trans%handle, LDSPLITLAT=booltmp ) !bool1(:) = booltmp(:) !deallocate( booltmp ) iret = TRANS_NOTIMPL return elseif( var == "nultpp" ) then call allocate_ptr( trans%nultpp, trans%nprtrns, int1 ) call TRANS_INQ( KRESOL=trans%handle, KULTPP=int1 ) elseif( var == "nptrls" ) then call allocate_ptr( trans%nptrls, trans%nprtrns, int1 ) call TRANS_INQ( KRESOL=trans%handle, KPTRLS=int1 ) elseif( var == "nnmeng" ) then call allocate_ptr( trans%nnmeng, trans%ndgl, int1 ) call TRANS_INQ( KRESOL=trans%handle, KNMENG=int1 ) elseif( var == "rmu" ) then call allocate_ptr( trans%rmu, trans%ndgl, double1 ) call TRANS_INQ( KRESOL=trans%handle, PMU=double1 ) elseif( var == "rgw" ) then call allocate_ptr( trans%rgw, trans%ndgl, double1 ) call TRANS_INQ( KRESOL=trans%handle, PGW=double1 ) elseif( var == "rpnm" ) then call allocate_ptr( trans%rpnm, trans%nlei3, trans%nspolegl, double2 ) call TRANS_INQ( KRESOL=trans%handle, PRPNM=double2 ) elseif( var == "npms" ) then call allocate_ptr( trans%npms, trans%nsmax+1, int1 ) call TRANS_INQ( KRESOL=trans%handle, KPMS=int1 ) elseif( var == "rlapin" ) then call allocate_ptr( trans%rlapin, trans%nsmax+4, double1 ) call TRANS_INQ( KRESOL=trans%handle, PLAPIN=double1 ) elseif( var == "ndglu" ) then call allocate_ptr( trans%ndglu, trans%nsmax+1, int1 ) call TRANS_INQ( KRESOL=trans%handle, KDGLU=int1 ) elseif( var /= "ndgl" & & .and. var /= "nsmax" & & .and. var /= "myproc" & & .and. var /= "nproc" & & .and. var /= "llam" & & .and. var /= "nspec" & & .and. var /= "nspec2" & & .and. var /= "nspec2g" & & .and. var /= "nspec2mx" & & .and. var /= "nump" & & .and. var /= "ngptot" & & .and. var /= "ngptotg" & & .and. var /= "ngptotmx" & & .and. var /= "n_regions_ns" & & .and. var /= "n_regions_ew" & & .and. var /= "my_region_ns" & & .and. var /= "my_region_ew" & & .and. var /= "nfrstloff" & & .and. var /= "nptrfloff" & & .and. var /= "nprtrns" & & .and. var /= "nlei3" & & .and. var /= "nspolegl" & & .and. var /= "nmsmax" ) then write(error_unit,*) "trans_inqure: ERROR: unrecognized variable ", var iret = TRANS_UNRECOGNIZED_ARG return endif enddo iret = TRANS_SUCCESS end function trans_inquire_fstr subroutine free_ptr(ptr) use, intrinsic :: iso_c_binding type(c_ptr) :: ptr if( c_associated( ptr ) ) then call transi_free(ptr) ptr = c_null_ptr endif end subroutine free_ptr !subroutine allocate_bool1_ptr(ptr,len,bool1) ! use, intrinsic :: iso_c_binding ! type(c_ptr) :: ptr ! integer(c_int) :: len ! logical(c_bool), pointer :: bool1(:) ! if( .not. c_associated( ptr ) ) call transi_malloc_bool(ptr,len) ! call c_f_pointer( ptr, bool1, (/len/) ) !end subroutine allocate_bool1_ptr subroutine allocate_int1_ptr(ptr,len,int1) use, intrinsic :: iso_c_binding type(c_ptr) :: ptr integer(c_int) :: len integer(c_int), pointer :: int1(:) if( .not. c_associated( ptr ) ) call transi_malloc_int(ptr,len) call c_f_pointer( ptr, int1, (/len/) ) end subroutine allocate_int1_ptr subroutine allocate_int2_ptr(ptr,len1,len2,int2) use, intrinsic :: iso_c_binding type(c_ptr) :: ptr integer(c_int) :: len1, len2 integer(c_int), pointer :: int2(:,:) if( .not. c_associated( ptr ) ) call transi_malloc_int(ptr,len1*len2) call c_f_pointer( ptr, int2, (/len1,len2/) ) end subroutine allocate_int2_ptr subroutine allocate_double1_ptr(ptr,len,double1) use, intrinsic :: iso_c_binding type(c_ptr) :: ptr integer(c_int) :: len real(c_double), pointer :: double1(:) if( .not. c_associated( ptr ) ) call transi_malloc_double(ptr,len) call c_f_pointer( ptr, double1, (/len/) ) end subroutine allocate_double1_ptr subroutine allocate_double2_ptr(ptr,len1,len2,double2) use, intrinsic :: iso_c_binding type(c_ptr) :: ptr integer(c_int) :: len1, len2 real(c_double), pointer :: double2(:,:) if( .not. c_associated( ptr ) ) call transi_malloc_double(ptr,len1*len2) call c_f_pointer( ptr, double2, (/len1,len2/) ) end subroutine allocate_double2_ptr function trans_delete(trans) bind(C,name="trans_delete") use, intrinsic :: iso_c_binding integer(c_int) :: trans_delete type(Trans_t), intent(inout) :: trans trans_delete = TRANS_SUCCESS if (trans%handle == 0) then return endif call free_ptr( trans%nloen ) call free_ptr( trans%readfp ) call free_ptr( trans%writefp ) call free_ptr( trans%ngptotl ) call free_ptr( trans%nmyms ) call free_ptr( trans%nasm0 ) call free_ptr( trans%numpp ) call free_ptr( trans%npossp ) call free_ptr( trans%nptrms ) call free_ptr( trans%nallms ) call free_ptr( trans%ndim0g ) call free_ptr( trans%nvalue ) call free_ptr( trans%n_regions ) call free_ptr( trans%nfrstlat ) call free_ptr( trans%nlstlat ) call free_ptr( trans%nptrlat ) call free_ptr( trans%nptrfrstlat ) call free_ptr( trans%nptrlstlat ) call free_ptr( trans%nsta ) call free_ptr( trans%nonl ) call free_ptr( trans%ldsplitlat ) call free_ptr( trans%nultpp ) call free_ptr( trans%nptrls ) call free_ptr( trans%nnmeng ) call free_ptr( trans%rmu ) call free_ptr( trans%rgw ) call free_ptr( trans%rpnm ) call free_ptr( trans%npms ) call free_ptr( trans%rlapin ) call free_ptr( trans%ndglu ) call free_ptr( trans%mvalue ) if( .not. is_lam(trans) ) then call trans_release( trans%handle ) #if ECTRANS_HAVE_ETRANS else call etrans_release( trans%handle ) #endif endif end function trans_delete function trans_finalize() bind(C,name="trans_finalize") use, intrinsic :: iso_c_binding integer(c_int) :: trans_finalize call TRANS_END() if( USE_MPI ) call MPL_END(LDMEMINFO=.FALSE.) if( close_devnull ) then ! Don't close devnull in case other code is also using this unit ! close (devnull()) endif if( allocated(N_REGIONS) ) deallocate(N_REGIONS) is_init = .False. trans_finalize = TRANS_SUCCESS end function trans_finalize function get_nlon( trans ) result(nlon) use, intrinsic :: iso_c_binding, only : c_associated, c_f_pointer integer ::nlon type(Trans_t) :: trans integer, pointer :: nloen(:) nlon = trans%nlon if( nlon < 0 ) then if( c_associated( trans%nloen ) ) then call c_f_pointer( trans%nloen, nloen, (/trans%ndgl/) ) nlon = nloen(1) else nlon = 2*trans%ndgl endif endif end function function assert_global(trans,RGP) result(iret) integer :: iret type(Trans_t), intent(in) :: trans real(c_double), intent(in) :: RGP(:,:,:) !(NPROMA==ngptotg,NFLD,NGPBLKS==1) integer :: nproma, ngpblks, nlon iret = TRANS_SUCCESS nproma = size(RGP,1) ngpblks = size(RGP,3) if( trans%nproc /= 1 ) then call transi_error("assert_global: ERROR: Configuration only valid for nproc == 1") iret = TRANS_ERROR return endif if( trans%llatlon == 1 ) then nlon = get_nlon(trans) if( trans%ngptot /= trans%ngptotg + nlon ) then call transi_error("assert_global: ERROR: Assertion failed for lonlat grids: (ngptot == ngptotg+nlon)") iret = TRANS_ERROR return endif endif if( nproma /= trans%ngptotg ) then call transi_error("assert_global: ERROR: Configuration only valid for nproma == ngpgot") iret = TRANS_ERROR return endif if( ngpblks /= 1 ) then call transi_error("assert_global: ERROR: Configuration only valid for ngpblks == 1") iret = TRANS_ERROR return endif end function function prepare_global_invtrans(trans,RGP,RGPM) result(iret) integer :: iret type(Trans_t), intent(in) :: trans real(c_double), target, intent(in) :: RGP(:,:,:) !(NPROMA==ngptotg,NFLD,NGPBLKS==1) real(c_double), pointer, intent(out) :: RGPM(:,:,:) !(NPROMA==ngptot, NFLD,NGPBLKS==1) !! Modified RGP to add one duplicate latitude at equator integer :: nfld iret = assert_global(trans,RGP) if( iret /= TRANS_SUCCESS ) return if( trans%llatlon == 1 ) then nfld = size(RGP,2) allocate( RGPM(trans%ngptot,nfld,1) ) else RGPM => RGP endif end function function finish_global_invtrans(trans,RGP,RGPM) result(iret) integer :: iret type(Trans_t), intent(in) :: trans real(c_double), intent(inout) :: RGP(:,:,:) !(NPROMA==ngptotg,FIELD,NGPBLKS==1) real(c_double), pointer, intent(inout) :: RGPM(:,:,:) !(NPROMA==ngptotg,FIELD,NGPBLKS==1) !! Modified RGP with an added duplicate latitude at equator integer :: nlon, ilat, ilon, icount iret = assert_global(trans,RGP) if( iret /= TRANS_SUCCESS ) return if( trans%llatlon == 1 ) then nlon = get_nlon(trans) icount = 0 do ilat=1,trans%ndgl+2 if( ilat <= trans%ndgl/2 .or. ilat >= trans%ndgl/2+2) then do ilon=1,nlon icount=icount+1 RGP(icount,:,1) = RGPM(ilon+(ilat-1)*nlon,:,1) enddo ! ilon endif enddo ! ilat deallocate(RGPM) nullify(RGPM) else nullify(RGPM) endif end function function prepare_global_gptosp_trans(trans,RGP,RGPM) result(iret) integer :: iret type(Trans_t), intent(in) :: trans real(c_double), target, intent(in) :: RGP(:,:,:) !(NPROMA==ngptotg,NFLD,NGPBLKS==1) real(c_double), pointer, intent(out) :: RGPM(:,:,:) !(NPROMA==ngptot, NFLD,NGPBLKS==1) !! Modified RGP to add one duplicate latitude at equator integer :: nlon, ilat, ilon, icount, nfld iret = assert_global(trans,RGP) if( iret /= TRANS_SUCCESS ) return if( trans%llatlon == 1 ) then nfld = size(RGP,2) nlon = get_nlon(trans) icount = 0 allocate( RGPM(trans%ngptot,nfld,1) ) do ilat=1,trans%ndgl+2 ! There is 1 too little latitude in RGPM do ilon=1,nlon icount = icount+1 RGPM(ilon+(ilat-1)*nlon,:,1) = RGP(icount,:,1) enddo ! ilon if( ilat == trans%ndgl/2+1) then icount = icount-nlon endif enddo ! ilat else RGPM => RGP endif end function function finish_global_gptosp_trans(trans,RGP,RGPM) result(iret) integer :: iret type(Trans_t), intent(in) :: trans real(c_double), intent(inout) :: RGP(:,:,:) !(NPROMA==ngptotg,FIELD,NGPBLKS==1) real(c_double), pointer, intent(inout) :: RGPM(:,:,:) !(NPROMA==ngptotg,FIELD,NGPBLKS==1) !! Modified RGP with an added duplicate latitude at equator iret = assert_global(trans,RGP) if( iret /= TRANS_SUCCESS ) return if( trans%llatlon == 1 ) then deallocate(RGPM) nullify(RGPM) else nullify(RGPM) endif end function function trans_dirtrans(args) bind(C,name="trans_dirtrans") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(DirTrans_t), intent(inout) :: args real(c_double), pointer :: RSPVOR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPDIV(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPSCALAR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RMEANU(:) !(FIELD) real(c_double), pointer :: RMEANV(:) !(FIELD) real(c_double), pointer :: RGP(:,:,:) !(NPROMA,IF_GP,NGPBLKS) real(c_double), pointer :: RGPM(:,:,:) !(NPROMA,FIELD,NGPBLKS) type(Trans_t), pointer :: trans logical :: llatlon if( args%count > 0 ) then call transi_error("trans_dirtrans: ERROR: arguments are not new") iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_dirtrans: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%rgp) ) then call transi_error( "trans_dirtrans: ERROR: Array RGP was not allocated" ) iret = TRANS_MISSING_ARG return endif if( args%nvordiv > 0 ) then if( .not. c_associated(args%rspvor) ) then call transi_error( "trans_dirtrans: ERROR: Array RSPVOR was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rspdiv) ) then call transi_error( "trans_dirtrans: ERROR: Array RSPDIV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspvor, RSPVOR, (/args%nvordiv, trans%nspec2/) ) call c_f_pointer(args%rspdiv, RSPDIV, (/args%nvordiv, trans%nspec2/) ) if( is_lam(trans) ) then if( .not. c_associated(args%rmeanu) ) then call transi_error( "trans_dirtrans: ERROR: Array RMEANU was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rmeanv) ) then call transi_error( "trans_dirtrans: ERROR: Array RMEANV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rmeanu, RMEANU, (/args%nvordiv/) ) call c_f_pointer(args%rmeanv, RMEANV, (/args%nvordiv/) ) endif endif if( args%nscalar > 0 ) then if( .not. c_associated(args%rspscalar) ) then call transi_error( "trans_dirtrans: ERROR: Array RSPSCALAR was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspscalar, RSPSCALAR, (/args%nscalar, trans%nspec2/) ) endif llatlon = .false. if( trans%llatlon /= 0 ) llatlon = .true. if( args%lglobal == 1 ) then call c_f_pointer( args%rgp, RGP, (/trans%ngptotg,args%nscalar+2*args%nvordiv,1/) ) iret = prepare_global_gptosp_trans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else call c_f_pointer( args%rgp, RGP, (/args%nproma,args%nscalar+2*args%nvordiv,args%ngpblks/) ) RGPM => RGP endif if( args%nvordiv > 0 .and. args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call DIR_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDLATLON=llatlon, & & PGP=RGPM, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EDIR_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & PGP=RGP, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR,PMEANU=RMEANU,PMEANV=RMEANV ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call DIR_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDLATLON=llatlon, & & PGP=RGPM, & & PSPSCALAR=RSPSCALAR ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EDIR_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & PGP=RGP, & & PSPSCALAR=RSPSCALAR ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nvordiv > 0 ) then if( .not. is_lam(trans) ) then call DIR_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDLATLON=llatlon, & & PGP=RGPM, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EDIR_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & PGP=RGP, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PMEANU=RMEANU,PMEANV=RMEANV ) ! unused args: KVSETUV,KVSETSC #endif endif endif if( args%lglobal == 1 ) then iret = finish_global_gptosp_trans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else nullify(RGPM) endif iret = TRANS_SUCCESS end function trans_dirtrans function trans_dirtrans_adj(args) bind(C,name="trans_dirtrans_adj") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(DirTransAdj_t), intent(inout) :: args real(c_double), pointer :: RSPVOR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPDIV(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPSCALAR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RMEANU(:) !(FIELD) real(c_double), pointer :: RMEANV(:) !(FIELD) real(c_double), pointer :: RGP(:,:,:) !(NPROMA,IF_GP,NGPBLKS) real(c_double), pointer :: RGPM(:,:,:) !(NPROMA,FIELD,NGPBLKS) type(Trans_t), pointer :: trans logical :: llatlon if( args%count > 0 ) then call transi_error("trans_dirtrans_adj: ERROR: arguments are not new") iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_dirtrans_adj: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%rgp) ) then call transi_error( "trans_dirtrans_adj: ERROR: Array RGP was not allocated" ) iret = TRANS_MISSING_ARG return endif if( args%nvordiv > 0 ) then if( .not. c_associated(args%rspvor) ) then call transi_error( "trans_dirtrans_adj: Array RSPVOR was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rspdiv) ) then call transi_error( "trans_dirtrans_adj: Array RSPDIV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspvor, RSPVOR, (/args%nvordiv, trans%nspec2/) ) call c_f_pointer(args%rspdiv, RSPDIV, (/args%nvordiv, trans%nspec2/) ) if( is_lam(trans) ) then if( .not. c_associated(args%rmeanu) ) then call transi_error( "trans_dirtrans_adj: Array RMEANU was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rmeanv) ) then call transi_error( "trans_dirtrans_adj: Array RMEANV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rmeanu, RMEANU, (/args%nvordiv/) ) call c_f_pointer(args%rmeanv, RMEANV, (/args%nvordiv/) ) endif endif if( args%nscalar > 0 ) then if( .not. c_associated(args%rspscalar) ) then call transi_error( "trans_dirtrans_adj: Array RSPSCALAR was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspscalar, RSPSCALAR, (/args%nscalar, trans%nspec2/) ) endif llatlon = .false. if( trans%llatlon /= 0 ) llatlon = .true. if( args%lglobal == 1 ) then call c_f_pointer( args%rgp, RGP, (/trans%ngptotg,args%nscalar+2*args%nvordiv,1/) ) iret = prepare_global_invtrans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else call c_f_pointer( args%rgp, RGP, (/args%nproma,args%nscalar+2*args%nvordiv,args%ngpblks/) ) RGPM => RGP endif if( args%nvordiv > 0 .and. args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call DIR_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & ! & LDLATLON=llatlon, & & PGP=RGPM, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EDIR_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & & PGP=RGP, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR,PMEANU=RMEANU,PMEANV=RMEANV ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call DIR_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & ! & LDLATLON=llatlon, & & PGP=RGPM, & & PSPSCALAR=RSPSCALAR ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EDIR_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & & PGP=RGP, & & PSPSCALAR=RSPSCALAR ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nvordiv > 0 ) then if( .not. is_lam(trans) ) then call DIR_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & ! & LDLATLON=llatlon, & & PGP=RGPM, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EDIR_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & & PGP=RGP, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PMEANU=RMEANU,PMEANV=RMEANV ) ! unused args: KVSETUV,KVSETSC #endif endif endif if( args%lglobal == 1 ) then !TO DO MW - CHECK WHETHER CORRECT iret = finish_global_invtrans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else nullify(RGPM) endif iret = TRANS_SUCCESS end function trans_dirtrans_adj function trans_invtrans(args) bind(C,name="trans_invtrans") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(InvTrans_t), intent(inout) :: args real(c_double), pointer :: RSPVOR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPDIV(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPSCALAR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RMEANU(:) !(FIELD) real(c_double), pointer :: RMEANV(:) !(FIELD) real(c_double), pointer :: RGP(:,:,:) !(NPROMA,FIELD,NGPBLKS) real(c_double), pointer :: RGPM(:,:,:) !(NPROMA,FIELD,NGPBLKS) logical :: lscalarders logical :: luvder_EW logical :: lvordivgp logical :: llatlon type(Trans_t), pointer :: trans integer :: nfld_gp if( args%count > 0 ) then call transi_error( "trans_invtrans: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_invtrans: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%rgp) ) then call transi_error( "trans_invtrans: ERROR: Array RGP was not allocated" ) iret = TRANS_MISSING_ARG return endif lscalarders = .false.; if( args%lscalarders == 1 ) lscalarders = .true. luvder_EW = .false.; if( args%luvder_EW == 1 ) luvder_EW = .true. lvordivgp = .false.; if( args%lvordivgp == 1 ) lvordivgp = .true. if( args%nvordiv > 0 ) then if( .not. c_associated(args%rspvor) ) then call transi_error( "trans_invtrans: ERROR: Array RSPVOR was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rspdiv) ) then call transi_error( "trans_invtrans: ERROR: Array RSPDIV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspvor, RSPVOR, (/args%nvordiv, trans%nspec2/) ) call c_f_pointer(args%rspdiv, RSPDIV, (/args%nvordiv, trans%nspec2/) ) if( is_lam(trans) ) then if( .not. c_associated(args%rmeanu) ) then call transi_error( "trans_invtrans: ERROR: Array RMEANU was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rmeanv) ) then call transi_error( "trans_invtrans: ERROR: Array RMEANV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rmeanu, RMEANU, (/args%nvordiv/) ) call c_f_pointer(args%rmeanv, RMEANV, (/args%nvordiv/) ) endif endif if( args%nscalar > 0 ) then if( .not. c_associated(args%rspscalar) ) then call transi_error( "trans_invtrans: ERROR: Array RSPSCALAR was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspscalar, RSPSCALAR, (/args%nscalar, trans%nspec2/) ) endif llatlon = .false. if( trans%llatlon /= 0 ) llatlon = .true. nfld_gp = 0 if( lvordivgp ) nfld_gp = nfld_gp + 2*args%nvordiv ! voriticty + divergence if( .true. ) nfld_gp = nfld_gp + args%nscalar ! scalars if( .true. ) nfld_gp = nfld_gp + 2*args%nvordiv ! u + v if( lscalarders ) nfld_gp = nfld_gp + args%nscalar ! scalars N-S derivatives if( luvder_EW ) nfld_gp = nfld_gp + 2*args%nvordiv ! u + v E-W derivatives if( lscalarders ) nfld_gp = nfld_gp + args%nscalar ! scalars E-W derivatives if( args%lglobal == 1 ) then call c_f_pointer( args%rgp, RGP, (/trans%ngptotg,nfld_gp,1/) ) iret = prepare_global_invtrans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else call c_f_pointer( args%rgp, RGP, (/args%nproma,nfld_gp,args%ngpblks/) ) RGPM => RGP endif if( args%nvordiv > 0 .and. args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call INV_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDLATLON=llatlon, & & LDSCDERS=lscalarders, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR, & & PGP=RGPM ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EINV_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDSCDERS=lscalarders, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR, & & PMEANU=RMEANU,PMEANV=RMEANV, & & PGP=RGP ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call INV_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDLATLON=llatlon, & & LDSCDERS=lscalarders, & & PSPSCALAR=RSPSCALAR, & & PGP=RGPM ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EINV_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDSCDERS=lscalarders, & & PSPSCALAR=RSPSCALAR, & & PGP=RGP ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nvordiv > 0 ) then if( .not. is_lam(trans) ) then call INV_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDLATLON=llatlon, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV, & & PGP=RGPM ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EINV_TRANS( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV, & & PMEANU=RMEANU,PMEANV=RMEANV, & & PGP=RGP ) ! unused args: KVSETUV,KVSETSC #endif endif endif if( args%lglobal == 1 ) then iret = finish_global_invtrans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else nullify(RGPM) endif iret = TRANS_SUCCESS end function trans_invtrans function trans_invtrans_adj(args) bind(C,name="trans_invtrans_adj") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(InvTransAdj_t), intent(inout) :: args real(c_double), pointer :: RSPVOR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPDIV(:,:) !(FIELD,WAVE) real(c_double), pointer :: RSPSCALAR(:,:) !(FIELD,WAVE) real(c_double), pointer :: RMEANU(:) !(FIELD) real(c_double), pointer :: RMEANV(:) !(FIELD) real(c_double), pointer :: RGP(:,:,:) !(NPROMA,FIELD,NGPBLKS) real(c_double), pointer :: RGPM(:,:,:) !(NPROMA,FIELD,NGPBLKS) logical :: lscalarders logical :: luvder_EW logical :: lvordivgp logical :: llatlon type(Trans_t), pointer :: trans integer :: nfld_gp if( args%count > 0 ) then call transi_error( "trans_invtrans_adj: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_invtrans_adj:trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%rgp) ) then call transi_error( "trans_invtrans_adj:Array RGP was not allocated" ) iret = TRANS_MISSING_ARG return endif lscalarders = .false.; if( args%lscalarders == 1 ) lscalarders = .true. luvder_EW = .false.; if( args%luvder_EW == 1 ) luvder_EW = .true. lvordivgp = .false.; if( args%lvordivgp == 1 ) lvordivgp = .true. if( args%nvordiv > 0 ) then if( .not. c_associated(args%rspvor) ) then call transi_error( "trans_invtrans_adj: ERROR: Array RSPVOR was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rspdiv) ) then call transi_error( "trans_invtrans_adj: ERROR: Array RSPDIV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspvor, RSPVOR, (/args%nvordiv, trans%nspec2/) ) call c_f_pointer(args%rspdiv, RSPDIV, (/args%nvordiv, trans%nspec2/) ) if( is_lam(trans) ) then if( .not. c_associated(args%rmeanu) ) then call transi_error( "trans_invtrans_adj: ERROR: Array RMEANU was not allocated" ) iret = TRANS_MISSING_ARG return endif if( .not. c_associated(args%rmeanv) ) then call transi_error( "trans_invtrans_adj: ERROR: Array RMEANV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rmeanu, RMEANU, (/args%nvordiv/) ) call c_f_pointer(args%rmeanv, RMEANV, (/args%nvordiv/) ) endif endif if( args%nscalar > 0 ) then if( .not. c_associated(args%rspscalar) ) then call transi_error( "trans_invtrans_adj: ERROR: Array RSPSCALAR was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer(args%rspscalar, RSPSCALAR, (/args%nscalar, trans%nspec2/) ) endif llatlon = .false. if( trans%llatlon /= 0 ) llatlon = .true. nfld_gp = 0 if( lvordivgp ) nfld_gp = nfld_gp + 2*args%nvordiv ! voriticty + divergence if( .true. ) nfld_gp = nfld_gp + args%nscalar ! scalars if( .true. ) nfld_gp = nfld_gp + 2*args%nvordiv ! u + v if( lscalarders ) nfld_gp = nfld_gp + args%nscalar ! scalars N-S derivatives if( luvder_EW ) nfld_gp = nfld_gp + 2*args%nvordiv ! u + v E-W derivatives if( lscalarders ) nfld_gp = nfld_gp + args%nscalar ! scalars E-W derivatives if( args%lglobal == 1 ) then call c_f_pointer( args%rgp, RGP, (/trans%ngptotg,nfld_gp,1/) ) iret = prepare_global_gptosp_trans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else call c_f_pointer( args%rgp, RGP, (/args%nproma,nfld_gp,args%ngpblks/) ) RGPM => RGP endif if( args%nvordiv > 0 .and. args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call INV_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & ! & LDLATLON=llatlon, & & LDSCDERS=lscalarders, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR, & & PGP=RGPM ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EINV_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDSCDERS=lscalarders, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPSCALAR=RSPSCALAR, & & PMEANU=RMEANU,PMEANV=RMEANV, & & PGP=RGP ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nscalar > 0 ) then if( .not. is_lam(trans) ) then call INV_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & ! & LDLATLON=llatlon, & & LDSCDERS=lscalarders, & & PSPSCALAR=RSPSCALAR, & & PGP=RGPM ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EINV_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDSCDERS=lscalarders, & & PSPSCALAR=RSPSCALAR, & & PGP=RGP ) ! unused args: KVSETUV,KVSETSC #endif endif elseif( args%nvordiv > 0 ) then if( .not. is_lam(trans) ) then call INV_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & ! & LDLATLON=llatlon, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV, & & PGP=RGPM ) ! unused args: KVSETUV,KVSETSC #if ECTRANS_HAVE_ETRANS else call EINV_TRANSAD( KRESOL=trans%handle, & & KPROMA=args%nproma, & & LDVORGP=lvordivgp, & & LDDIVGP=lvordivgp, & & LDUVDER=luvder_EW, & & PSPVOR=RSPVOR,PSPDIV=RSPDIV, & & PMEANU=RMEANU,PMEANV=RMEANV, & & PGP=RGP ) ! unused args: KVSETUV,KVSETSC #endif endif endif if( args%lglobal == 1 ) then iret = finish_global_gptosp_trans(trans,RGP,RGPM) if( iret /= TRANS_SUCCESS ) return else nullify(RGPM) endif iret = TRANS_SUCCESS end function trans_invtrans_adj function trans_distgrid(args) bind(C,name="trans_distgrid") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(DistGrid_t), intent(inout) :: args real(c_double), pointer :: RGPG(:,:) ! (NFLD_from,NGPTOTG (+nlon) ) (+nlon in case of LonLat grid) real(c_double), pointer :: LL_RGPG(:,:) ! (NFLD_from,NGPTOTG ) real(c_double), pointer :: RGP (:,:,:) ! (NPROMA,IF_GP,NGPBLKS) integer(c_int), pointer :: NFROM(:) type(Trans_t), pointer :: trans integer :: jfld, isend, jsend integer :: icount, ilat, ilon, nlon integer :: check integer(c_int), pointer :: nloen(:) if( args%count > 0 ) then call transi_error( "trans_distgrid: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_distgrid: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%nfrom) ) then call transi_error( "trans_distgrid: ERROR: Array NFROM was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%nfrom, NFROM, (/args%nfld/) ) isend = 0 do jfld = 1, args%nfld if ( NFROM(jfld) == trans%myproc ) isend = isend + 1 enddo if( .not. c_associated(args%rgp) ) then call transi_error( "trans_distgrid: ERROR: Array RGP was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rgp, RGP, (/args%nproma,args%nfld,args%ngpblks/) ) if( isend > 0 ) then if( .not. c_associated(args%rgpg) ) then call transi_error( "trans_distgrid: ERROR: Array RGPG was not allocated" ) iret = TRANS_MISSING_ARG return endif if( trans%llatlon == 1 ) then nlon = trans%nlon if( nlon < 0 ) then if( c_associated( trans%nloen ) ) then call c_f_pointer( trans%nloen, nloen, (/trans%ndgl/) ) nlon = nloen(1) else nlon = 2*trans%ndgl endif endif call c_f_pointer( args%rgpg, LL_RGPG, (/trans%ngptotg,isend/) ) allocate( RGPG(trans%ngptotg+nlon,isend) ) ! 1 extra latitudes should be allocated do jsend=1,isend check = 0 icount = 0 do ilat=1,trans%ndgl+2 ! There is 1 too little latitude in LL_RGPG do ilon=1,nlon ICOUNT=ICOUNT+1 RGPG(ILON+(ILAT-1)*nlon,jsend) = LL_RGPG(ICOUNT,jsend) check = check+1 enddo ! ilon if( ilat == trans%ndgl/2+1) then ICOUNT = ICOUNT-nlon endif enddo ! ilat if( check /= trans%ngptotg+nlon ) then call transi_error( "trans_distgrid: ERROR: not all values are assigned" ) iret = TRANS_ERROR deallocate( RGPG ) return endif enddo ! jsend else call c_f_pointer( args%rgpg, RGPG, (/trans%ngptotg,isend/) ) endif ! llatlon if( .not. is_lam(trans) ) then call DIST_GRID( PGPG=RGPG,KFDISTG=args%nfld,KFROM=NFROM,KPROMA=args%nproma,KRESOL=trans%handle,PGP=RGP) #if ECTRANS_HAVE_ETRANS else call EDIST_GRID(PGPG=RGPG,KFDISTG=args%nfld,KFROM=NFROM,KPROMA=args%nproma,KRESOL=trans%handle,PGP=RGP) #endif endif if( trans%llatlon == 1 ) then deallocate( RGPG ) endif else if( .not. is_lam(trans) ) then call DIST_GRID( KFDISTG=args%nfld,KFROM=NFROM,KPROMA=args%nproma,KRESOL=trans%handle,PGP=RGP) #if ECTRANS_HAVE_ETRANS else call EDIST_GRID( KFDISTG=args%nfld,KFROM=NFROM,KPROMA=args%nproma,KRESOL=trans%handle,PGP=RGP) #endif endif endif iret = TRANS_SUCCESS end function trans_distgrid function trans_gathgrid(args) bind(C,name="trans_gathgrid") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(GathGrid_t), intent(inout) :: args real(c_double), pointer :: RGPG(:,:) !(NFLD_to,NGPTOTG) real(c_double), pointer :: RGP (:,:,:) !(NPROMA,NFLD,NGPBLKS) integer(c_int), pointer :: NTO(:) type(Trans_t), pointer :: trans real(c_double), pointer :: LL_RGPG (:,:) integer :: jfld, irecv integer :: icount, ilat, ilon, jrecv, nlon integer(c_int), pointer :: nloen(:) if( args%count > 0 ) then call transi_error( "trans_gathgrid: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_gathgrid: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%nto) ) then call transi_error( "trans_gathgrid: ERROR: trans_gath_grid: Array NTO was not allocated") iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%nto, NTO, (/args%nfld/) ) irecv = 0 do jfld = 1, args%nfld if ( NTO(jfld) == trans%myproc ) irecv = irecv + 1 enddo if( .not. c_associated(args%rgp) ) then call transi_error( "trans_gathgrid: ERROR: Array RGP was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rgp, RGP, (/args%nproma,args%nfld,args%ngpblks/) ) if( irecv > 0 ) then if( .not. c_associated(args%rgpg) ) then call transi_error( "trans_gathgrid: ERROR: Array RGPG was not allocated" ) iret = TRANS_MISSING_ARG return endif if( trans%llatlon == 1 ) then nlon = trans%nlon if( nlon < 0 ) then if( c_associated( trans%nloen ) ) then call c_f_pointer( trans%nloen, nloen, (/trans%ndgl/) ) nlon = nloen(1) else nlon = 2*trans%ndgl endif endif allocate( RGPG(trans%ngptotg+nlon,irecv) ) ! 1 extra latitudes else call c_f_pointer( args%rgpg, RGPG, (/trans%ngptotg,irecv/) ) endif if( .not. is_lam(trans) ) then call GATH_GRID(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,KPROMA=args%nproma,PGP=RGP,PGPG=RGPG) #if ECTRANS_HAVE_ETRANS else call EGATH_GRID(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,KPROMA=args%nproma,PGP=RGP,PGPG=RGPG) #endif endif if( trans%llatlon == 1 ) then ! There is 1 too many latitude in RGPG call c_f_pointer( args%rgpg, LL_RGPG, (/trans%ngptotg,irecv/) ) do jrecv=1,irecv icount = 0 do ilat=1,trans%ndgl+2 do ilon=1,nlon if( ilat <= trans%ndgl/2 .or. ilat >= trans%ndgl/2+2) then ICOUNT=ICOUNT+1 LL_RGPG(ICOUNT,jrecv) = RGPG(ILON+(ILAT-1)*nlon,jrecv) endif enddo ! ilon enddo ! ilat if( ICOUNT /= trans%ngptotg) then call transi_error( "trans_gathgrid: ERROR: CHECK failed" ) iret = TRANS_ERROR deallocate( RGPG ) return endif enddo ! jrecv deallocate( RGPG ) endif else if( .not. is_lam(trans) ) then call GATH_GRID(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,KPROMA=args%nproma,PGP=RGP) #if ECTRANS_HAVE_ETRANS else call EGATH_GRID(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,KPROMA=args%nproma,PGP=RGP) #endif endif endif iret = TRANS_SUCCESS end function trans_gathgrid function trans_distspec(args) bind(C,name="trans_distspec") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(DistSpec_t), intent(inout) :: args real(c_double), pointer :: RSPEC (:,:) ! (NFLD,NSPEC2) real(c_double), pointer :: RSPECG(:,:) ! (NFLD_from,NSPEC2G) integer(c_int), pointer :: NFROM(:) type(Trans_t), pointer :: trans integer :: jfld, isend if( args%count > 0 ) then call transi_error( "trans_distspec: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_distspec: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%nfrom) ) then call transi_error( "trans_distspec: ERROR: Array NFROM was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%nfrom, NFROM, (/args%nfld/) ) isend = 0 do jfld = 1, args%nfld if ( NFROM(jfld) == trans%myproc ) isend = isend + 1 enddo if( .not. c_associated(args%rspec) ) then call transi_error( "trans_distspec: ERROR: Array RSPEC was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspec, RSPEC, (/args%nfld,trans%nspec2/) ) if( isend > 0 ) then if( .not. c_associated(args%rspecg) ) then call transi_error( "trans_distspec: ERROR: Array RSPECG was not allocated" ) endif call c_f_pointer( args%rspecg, RSPECG, (/isend,trans%nspec2g/) ) if( .not. is_lam(trans) ) then call DIST_SPEC(KRESOL=trans%handle,KFDISTG=args%nfld,KFROM=NFROM,PSPEC=RSPEC,PSPECG=RSPECG) #if ECTRANS_HAVE_ETRANS else call EDIST_SPEC(KRESOL=trans%handle,KFDISTG=args%nfld,KFROM=NFROM,PSPEC=RSPEC,PSPECG=RSPECG) #endif endif else if( .not. is_lam(trans) ) then call DIST_SPEC(KRESOL=trans%handle,KFDISTG=args%nfld,KFROM=NFROM,PSPEC=RSPEC) #if ECTRANS_HAVE_ETRANS else call EDIST_SPEC(KRESOL=trans%handle,KFDISTG=args%nfld,KFROM=NFROM,PSPEC=RSPEC) #endif endif endif iret = TRANS_SUCCESS end function trans_distspec function trans_gathspec(args) bind(C,name="trans_gathspec") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(GathSpec_t), intent(inout) :: args real(c_double), pointer :: RSPEC(:,:) ! (NFLD,NSPEC2) real(c_double), pointer :: RSPECG(:,:) ! (NFLD_to,NSPEC2G) integer(c_int), pointer :: NTO(:) type(Trans_t), pointer :: trans integer :: jfld, irecv if( args%count > 0 ) then call transi_error( "trans_gathspec: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_gathspec: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( .not. c_associated(args%nto) ) then call transi_error( "trans_gathspec: ERROR: Array NTO was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%nto, NTO, (/args%nfld/) ) irecv = 0 do jfld = 1, args%nfld if ( NTO(jfld) == trans%myproc ) irecv = irecv + 1 enddo if( .not. c_associated(args%rspec) ) then call transi_error( "trans_gathspec: ERROR: Array RSPEC was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspec, RSPEC, (/args%nfld,trans%nspec2/) ) if( irecv > 0 ) then if( .not. c_associated(args%rspecg) ) then call transi_error( "trans_gathspec: ERROR: Array RSPECG was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspecg, RSPECG, (/irecv,trans%nspec2g/) ) if( .not. is_lam(trans) ) then call GATH_SPEC(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,PSPEC=RSPEC,PSPECG=RSPECG) #if ECTRANS_HAVE_ETRANS else call EGATH_SPEC(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,PSPEC=RSPEC,PSPECG=RSPECG) #endif endif else if( .not. is_lam(trans) ) then call GATH_SPEC(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,PSPEC=RSPEC) #if ECTRANS_HAVE_ETRANS else call EGATH_SPEC(KRESOL=trans%handle,KFGATHG=args%nfld,KTO=NTO,PSPEC=RSPEC) #endif endif endif iret = TRANS_SUCCESS end function trans_gathspec function trans_vordiv_to_UV(args) bind(C,name="trans_vordiv_to_UV") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(VorDivToUV_t), intent(inout) :: args real(c_double), pointer :: RSPVOR(:,:) real(c_double), pointer :: RSPDIV(:,:) real(c_double), pointer :: RSPU(:,:) real(c_double), pointer :: RSPV(:,:) integer(c_int) :: err if( args%count > 0 ) then call transi_error( "trans_vordiv_to_UV: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( args%ncoeff == 0 ) then call transi_error( "trans_vordiv_to_UV: ERROR: missing argument nspec2") iret = TRANS_MISSING_ARG return endif if( args%nsmax == 0 ) then call transi_error( "trans_vordiv_to_UV: ERROR: missing argument nsmax") iret = TRANS_MISSING_ARG return endif ! Set vorticity if( .not. c_associated(args%rspvor) ) then call transi_error( "trans_vordiv_to_UV: ERROR: Array RSPVOR was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspvor, RSPVOR, (/args%nfld,args%ncoeff/) ) ! Set divergence if( .not. c_associated(args%rspdiv) ) then call transi_error( "trans_vordiv_to_UV: ERROR: Array RSPDIV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspdiv, RSPDIV, (/args%nfld,args%ncoeff/) ) ! Set U if( .not. c_associated(args%rspu) ) then call transi_error( "trans_vordiv_to_UV: ERROR: Array RSPU was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspu, RSPU, (/args%nfld,args%ncoeff/) ) ! Set V if( .not. c_associated(args%rspv) ) then call transi_error( "trans_vordiv_to_UV: ERROR: Array RSPV was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspv, RSPV, (/args%nfld,args%ncoeff/) ) #ifdef ECTRANS_GPU_VERSION call transi_error("trans_vordiv_to_UV: ERROR: Not implemented for GPU") iret = TRANS_NOTIMPL return #endif if ( .not. is_init ) then err = trans_init() endif ! PSPVOR(:,:) - spectral vorticity (input) ! PSPDIV(:,:) - spectral divergence (input) ! PSPU(:,:) - spectral U (u*cos(theta) (output) ! PSPV(:,:) - spectral V (v*cos(theta) (output) ! KSMAX - spectral resolution (input) call VORDIV_TO_UV(PSPVOR=RSPVOR,PSPDIV=RSPDIV,PSPU=RSPU,PSPV=RSPV,KSMAX=args%nsmax) iret = TRANS_SUCCESS end function trans_vordiv_to_UV function trans_specnorm(args) bind(C,name="trans_specnorm") result(iret) use, intrinsic :: iso_c_binding integer(c_int) :: iret type(SpecNorm_t), intent(inout) :: args real(c_double), pointer :: RSPEC(:,:) !(IF_GP,NGPTOTG) real(c_double), pointer :: RNORM(:) real(c_double), pointer :: RMET(:) type(Trans_t), pointer :: trans if( args%count > 0 ) then call transi_error( "trans_specnorm: ERROR: arguments are not new" ) iret = TRANS_STALE_ARG return endif args%count = 1 if( .not. c_associated(args%trans) ) then call transi_error( "trans_specnorm: ERROR: trans was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%trans, trans ) if( args%nfld == 0 ) then iret = TRANS_SUCCESS return endif if( .not. c_associated(args%rspec) ) then call transi_error( "trans_specnorm: ERROR: Array RSPEC was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rspec, RSPEC, (/args%nfld,trans%nspec2/) ) if( .not. c_associated(args%rnorm) ) then call transi_error( "trans_specnorm: ERROR: Array RNORM was not allocated" ) iret = TRANS_MISSING_ARG return endif call c_f_pointer( args%rnorm, RNORM, (/args%nfld/) ) if( c_associated(args%rmet) ) then call c_f_pointer( args%rmet, RMET, (/trans%nsmax+1/) ) RMET(0:) => RMET(:) endif if( .not. c_associated(args%rmet) ) then if( .not. is_lam(trans) ) then call SPECNORM(KRESOL=trans%handle,PSPEC=RSPEC,KMASTER=args%nmaster,PNORM=RNORM) #if ECTRANS_HAVE_ETRANS else call ESPECNORM(KRESOL=trans%handle,PSPEC=RSPEC,KMASTER=args%nmaster,PNORM=RNORM) #endif endif else if( .not. is_lam(trans) ) then call SPECNORM(KRESOL=trans%handle,PSPEC=RSPEC,KMASTER=args%nmaster,PNORM=RNORM,PMET=RMET) #if ECTRANS_HAVE_ETRANS else call ESPECNORM(KRESOL=trans%handle,PSPEC=RSPEC,KMASTER=args%nmaster,PNORM=RNORM,PMET=RMET) #endif endif endif iret = TRANS_SUCCESS end function trans_specnorm end module trans_module ectrans-1.8.0/src/transi/transi.c0000664000175000017500000001767115174631767017133 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ /* * @file transi/trans.c * @brief C-interface to the IFS trans-library * @author Willem Deconinck (nawd) * @date Jul 2014 */ #include #include #include #include "transi.h" /* * These functions are to be used in the fortran part (trans_module.F90) to * allocate and deallocate arrays of type C_PTR */ void transi_malloc_bool (void* ptr[], int len) { *ptr = malloc(sizeof(bool ) * len); } void transi_malloc_int (void* ptr[], int len) { *ptr = malloc(sizeof(int ) * len); } void transi_malloc_float (void* ptr[], int len) { *ptr = malloc(sizeof(float ) * len); } void transi_malloc_double(void* ptr[], int len) { *ptr = malloc(sizeof(double) * len); } void transi_free(void* ptr[]) { free(*ptr); *ptr=NULL; } #define TRANS_ERROR -1 #define TRANS_NOTIMPL -2 #define TRANS_MISSING_ARG -3 #define TRANS_UNRECOGNIZED_ARG -4 #define TRANS_STALE_ARG -5 const char* trans_error_msg(int errcode) { switch( errcode ) { case TRANS_SUCCESS: return "No error"; case TRANS_ERROR: return "Trans: Error"; case TRANS_NOTIMPL: return "Trans: Not implemented"; case TRANS_MISSING_ARG: return "Trans: Required member of the argument structure is missing or not allocated"; case TRANS_UNRECOGNIZED_ARG: return "Trans: Unrecognized argument"; case TRANS_STALE_ARG: return "Trans: Passed argument was already used in previous call"; default: return "Trans: Unknown error"; } } int trans_new( struct Trans_t* trans ) { trans->handle = 0; // not initialized trans->llatlon = 0; trans->lsplit = true; trans->flt = -1; trans->fft = TRANS_FFTW; trans->nsmax = -1; trans->nmsmax = -1; trans->ndgl = -1; trans->nlon = -1; trans->nloen = NULL; trans->readfp = NULL; trans->writefp = NULL; trans->cache = NULL; trans->cachesize = 0; trans->pweight=NULL; trans->llam = false; trans->ndgux=-1; trans->pexwn=1.; trans->peywn=1.; return TRANS_SUCCESS; } int trans_set_resol( struct Trans_t* trans, int ndgl, const int* nloen ) { size_t i; trans->ndgl = ndgl; trans->nloen = malloc( sizeof(int) * ndgl ); for ( i = 0; i < ndgl; ++i ) trans->nloen[i] = nloen[i]; return TRANS_SUCCESS; } int trans_set_resol_lonlat( struct Trans_t* trans, int nlon, int nlat ) { size_t i; if( nlat%2 == 0 ) // The shifted lonlat grid (excluding poles and equator) { trans->ndgl = nlat; trans->nlon = nlon; trans->llatlon = 2; if( trans->nloen ) free(trans->nloen); trans->nloen = malloc( sizeof(int) * nlat ); for ( i = 0; i < nlat; ++i ) trans->nloen[i] = nlon; } else // The lonlat grid including poles and equator { trans->ndgl = nlat-1; // Internally coefficients are computed with ndgl+2 (equator duplicated) trans->nlon = nlon; trans->llatlon = 1; } return TRANS_SUCCESS; } int trans_set_resol_lam( struct Trans_t* trans, int nx, int ny, double dx, double dy ) { trans->ndgl=ny; trans->nlon=nx; trans->pexwn=2.*M_PI/((double)nx*dx); trans->peywn=2.*M_PI/((double)ny*dy); trans->llam=true; // Sensible defaults for (linear) truncation // trans->nsmax=(ny-1)/2; // trans->nmsmax=(nx-1)/2; return TRANS_SUCCESS; } int trans_set_trunc( struct Trans_t* trans, int nsmax ) { trans->nsmax = nsmax; return TRANS_SUCCESS; } int trans_set_trunc_lam( struct Trans_t* trans, int trunc_x, int trunc_y ) { trans->llam=true; trans->nmsmax = trunc_x; trans->nsmax = trunc_y; return TRANS_SUCCESS; } int trans_set_read(struct Trans_t* trans, const char* filepath) { trans->readfp = malloc( sizeof(char)*1024 ); strcpy(trans->readfp, filepath); return TRANS_SUCCESS; } int trans_set_write(struct Trans_t* trans, const char* filepath) { trans->writefp = malloc( sizeof(char)*1024 ); strcpy(trans->writefp, filepath); return TRANS_SUCCESS; } int trans_set_cache(struct Trans_t* trans, const void* cache , size_t cachesize) { trans->cache = cache; trans->cachesize = cachesize; return TRANS_SUCCESS; } struct DirTrans_t new_dirtrans(struct Trans_t* trans) { struct DirTrans_t dirtrans; dirtrans.count = 0; dirtrans.rgp = NULL; dirtrans.rspscalar = NULL; dirtrans.rspvor = NULL; dirtrans.rspdiv = NULL; dirtrans.rmeanu = NULL; dirtrans.rmeanv = NULL; dirtrans.ngpblks = 1; dirtrans.nproma = trans->ngptot; dirtrans.nscalar = 0; dirtrans.nvordiv = 0; dirtrans.lglobal = 0; dirtrans.trans = trans; return dirtrans; } struct DirTransAdj_t new_dirtrans_adj(struct Trans_t* trans) { struct DirTransAdj_t dirtrans_adj; dirtrans_adj.count = 0; dirtrans_adj.rgp = NULL; dirtrans_adj.rspscalar = NULL; dirtrans_adj.rspvor = NULL; dirtrans_adj.rspdiv = NULL; dirtrans_adj.ngpblks = 1; dirtrans_adj.nproma = trans->ngptot; dirtrans_adj.nscalar = 0; dirtrans_adj.nvordiv = 0; dirtrans_adj.lglobal = 0; dirtrans_adj.trans = trans; return dirtrans_adj; } struct InvTrans_t new_invtrans(struct Trans_t* trans) { struct InvTrans_t invtrans; invtrans.count = 0; invtrans.rspscalar = NULL; invtrans.rspvor = NULL; invtrans.rspdiv = NULL; invtrans.rmeanu = NULL; invtrans.rmeanv = NULL; invtrans.rgp = NULL; invtrans.ngpblks = 1; invtrans.nproma = trans->ngptot; invtrans.nscalar = 0; invtrans.nvordiv = 0; invtrans.lscalarders = 0; invtrans.luvder_EW = 0; invtrans.lvordivgp = 0; invtrans.lglobal = 0; invtrans.trans = trans; return invtrans; } struct InvTransAdj_t new_invtrans_adj(struct Trans_t* trans) { struct InvTransAdj_t invtrans_adj; invtrans_adj.count = 0; invtrans_adj.rspscalar = NULL; invtrans_adj.rspvor = NULL; invtrans_adj.rspdiv = NULL; invtrans_adj.rgp = NULL; invtrans_adj.ngpblks = 1; invtrans_adj.nproma = trans->ngptot; invtrans_adj.nscalar = 0; invtrans_adj.nvordiv = 0; invtrans_adj.lscalarders = 0; invtrans_adj.luvder_EW = 0; invtrans_adj.lvordivgp = 0; invtrans_adj.lglobal = 0; invtrans_adj.trans = trans; return invtrans_adj; } struct DistGrid_t new_distgrid(struct Trans_t* trans) { struct DistGrid_t distgrid; distgrid.count = 0; distgrid.rgpg = NULL; distgrid.rgp = NULL; distgrid.nfrom = NULL; distgrid.ngpblks = 1; distgrid.nproma = trans->ngptot; distgrid.nfld = 0; distgrid.trans = trans; return distgrid; } struct GathGrid_t new_gathgrid(struct Trans_t* trans) { struct GathGrid_t gathgrid; gathgrid.count = 0; gathgrid.rgpg = NULL; gathgrid.rgp = NULL; gathgrid.nto = NULL; gathgrid.ngpblks = 1; gathgrid.nproma = trans->ngptot; gathgrid.nfld = 0; gathgrid.trans = trans; return gathgrid; } struct DistSpec_t new_distspec(struct Trans_t* trans) { struct DistSpec_t distspec; distspec.count = 0; distspec.rspecg = NULL; distspec.rspec = NULL; distspec.nfrom = NULL; distspec.trans = trans; return distspec; } struct GathSpec_t new_gathspec(struct Trans_t* trans) { struct GathSpec_t gathspec; gathspec.count = 0; gathspec.rspecg = NULL; gathspec.rspec = NULL; gathspec.nto = NULL; gathspec.trans = trans; return gathspec; } struct VorDivToUV_t new_vordiv_to_UV() { struct VorDivToUV_t vdtouv; vdtouv.count = 0; vdtouv.rspvor = NULL; vdtouv.rspdiv = NULL; vdtouv.rspu = NULL; vdtouv.rspv = NULL; vdtouv.nfld = 0; vdtouv.ncoeff = 0; vdtouv.nsmax = 0; return vdtouv; } struct SpecNorm_t new_specnorm(struct Trans_t* trans) { struct SpecNorm_t specnorm; specnorm.rspec = NULL; specnorm.nmaster = 1; specnorm.rmet = NULL; specnorm.rnorm = NULL; specnorm.nfld = 0; specnorm.trans = trans; specnorm.count = 0; return specnorm; } void transi_disable_DR_HOOK_ASSERT_MPI_INITIALIZED() { setenv("DR_HOOK_ASSERT_MPI_INITIALIZED","0",1); } ectrans-1.8.0/src/transi/version.c.in0000664000175000017500000000426215174631767017715 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #define ECTRANS_VERSION_STR "@ectrans_VERSION_STR@" #define ECTRANS_VERSION "@ectrans_VERSION@" #define ECTRANS_MAJOR_VERSION @ectrans_VERSION_MAJOR@ #define ECTRANS_MINOR_VERSION @ectrans_VERSION_MINOR@ #define ECTRANS_PATCH_VERSION @ectrans_VERSION_PATCH@ #define min(a, b) (((a) < (b)) ? (a) : (b)) #include #include #include const char * ectrans_version() { return ECTRANS_VERSION; } const char * ectrans_version_str() { return ECTRANS_VERSION_STR; } unsigned int ectrans_version_int() { return 10000*ECTRANS_MAJOR_VERSION + 100*ECTRANS_MINOR_VERSION + 1*ECTRANS_PATCH_VERSION; } static char* __git_sha1 = 0; const char * ectrans_git_sha1() { return "@ectrans_GIT_SHA1@"; } const char * ectrans_git_sha1_abbrev(unsigned int length) { int N = strlen(ectrans_git_sha1())-40+length; N = min(strlen(ectrans_git_sha1()),N); if( __git_sha1 ) free(__git_sha1); __git_sha1 = malloc( sizeof(char)*(N+1) ); memcpy( __git_sha1, ectrans_git_sha1(), N ); __git_sha1[N] = '\0'; return __git_sha1; } //----------------------------------------------------------------------------- extern const char * fiat_version(); extern unsigned int fiat_version_int(); extern const char * fiat_version_str(); extern const char * fiat_git_sha1(); extern const char * fiat_git_sha1_abbrev(unsigned int length); const char * ectrans_fiat_version() { return fiat_version(); } const char * ectrans_fiat_version_str() { return fiat_version_str(); } unsigned int ectrans_fiat_version_int() { return fiat_version_int(); } const char * ectrans_fiat_git_sha1() { return fiat_git_sha1(); } const char * ectrans_fiat_git_sha1_abbrev(unsigned int length) { return fiat_git_sha1_abbrev(length); } //----------------------------------------------------------------------------- ectrans-1.8.0/src/transi/version.h0000664000175000017500000000203015174631767017304 0ustar alastairalastair/* * (C) Copyright 2014- ECMWF. * * 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. */ #ifndef ectrans_version_h #define ectrans_version_h #ifndef __cplusplus // C99 header, defines bool as _Bool ( only required for C compiler ) #include #else extern "C" { #endif const char * ectrans_version(); unsigned int ectrans_version_int(); const char * ectrans_version_str(); const char * ectrans_git_sha1(); const char * ectrans_git_sha1_abbrev(unsigned int length); const char * ectrans_fiat_version(); unsigned int ectrans_fiat_version_int(); const char * ectrans_fiat_version_str(); const char * ectrans_fiat_git_sha1(); const char * ectrans_fiat_git_sha1_abbrev(unsigned int length); #ifdef __cplusplus } #endif #endif ectrans-1.8.0/src/transi/include/0000775000175000017500000000000015174631767017076 5ustar alastairalastairectrans-1.8.0/src/transi/include/ectrans/0000775000175000017500000000000015174631767020535 5ustar alastairalastairectrans-1.8.0/src/transi/include/ectrans/transi.h0000777000175000017500000000000015174631767024300 2../../transi.hustar alastairalastairectrans-1.8.0/src/transi/include/ectrans/version.h0000777000175000017500000000000015174631767024652 2../../version.hustar alastairalastairectrans-1.8.0/src/transi/CMakeLists.txt0000664000175000017500000000501015174631767020207 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. if( NOT ectrans_VERSION_PATCH ) set( ectrans_VERSION_PATCH 0 ) endif() configure_file( version.c.in version.c ) ecbuild_add_library( TARGET transi_dp SOURCES transi_module.F90 transi.h transi.c version.h ${CMAKE_CURRENT_BINARY_DIR}/version.c HEADER_DESTINATION include/ectrans PUBLIC_INCLUDES $ $ PRIVATE_LIBS trans_dp $<${ectrans_HAVE_ETRANS}:etrans_dp> PRIVATE_DEFINITIONS ECTRANS_HAVE_MPI=${HAVE_MPI} ECTRANS_HAVE_ETRANS=${ectrans_HAVE_ETRANS} ) ecbuild_target_fortran_module_directory( TARGET transi_dp MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/module/trans_dp ) if( HAVE_GPU ) ecbuild_add_library( TARGET transi_gpu_dp SOURCES transi_module.F90 transi.h transi.c version.h ${CMAKE_CURRENT_BINARY_DIR}/version.c HEADER_DESTINATION include/ectrans PUBLIC_INCLUDES $ $ PRIVATE_LIBS trans_gpu_dp $<${HAVE_ETRANS_GPU}:etrans_gpu_dp> PRIVATE_DEFINITIONS ECTRANS_HAVE_MPI=${HAVE_MPI} ECTRANS_GPU_VERSION ECTRANS_HAVE_ETRANS=0 ) if( HAVE_ACC AND CMAKE_Fortran_COMPILER_ID MATCHES NVHPC ) # Propagate flags as link options for downstream targets. Only required for NVHPC target_link_options( transi_gpu_dp INTERFACE $<$:SHELL:${OpenACC_Fortran_FLAGS}> $<$:SHELL:${OpenACC_Fortran_FLAGS}> $<$:SHELL:${OpenACC_Fortran_FLAGS}> ) endif() ecbuild_target_fortran_module_directory( TARGET transi_gpu_dp MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/module/trans_gpu_dp ) endif() set( transi_includes transi.h version.h ) install( FILES ${transi_includes} DESTINATION include/ectrans ) ectrans-1.8.0/src/programs/0000775000175000017500000000000015174631767016005 5ustar alastairalastairectrans-1.8.0/src/programs/ectrans-benchmark.F900000664000175000017500000020406015174631767021656 0ustar alastairalastair! (C) Copyright 2014- ECMWF. ! ! 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. ! program ectrans_benchmark ! ! Spectral transform test ! ! This test performs spectral to real and real to spectral transforms repeated in ! timed loop. ! ! Authors : George Mozdzynski ! Willem Deconinck ! Ioan Hadade ! Sam Hatfield ! use parkind1, only: jpim, jpib, jprb, jprd use oml_mod ,only : oml_max_threads use mpl_module use yomgstats, only: jpmaxstat, gstats_lstats => lstats use yomhook, only : dr_hook_init use ectrans_memory, only : allocator implicit none ! Number of points in top/bottom latitudes integer(kind=jpim), parameter :: min_octa_points = 20 integer(kind=jpim) :: istack, getstackusage real(kind=jprd) :: zmaxerr(5) real(kind=jprd) :: zmaxerrg ! Output unit numbers integer(kind=jpim), parameter :: nerr = 0 ! Unit number for STDERR integer(kind=jpim), parameter :: nout = 6 ! Unit number for STDOUT integer(kind=jpim), parameter :: noutdump = 7 ! Unit number for field output integer(kind=jpim), parameter :: noutdump_checksum = 8 ! Unit number for dump_checksum ! Default parameters integer(kind=jpim) :: iters = 10 ! Number of iterations for transform test integer(kind=jpim) :: nfld = 1 ! Number of 3D scalar fields integer(kind=jpim) :: nlev = 1 ! Number of vertical levels integer(kind=jpim) :: iters_warmup = 3 ! Number of warm up steps (for which timing statistics should be ignored) integer(kind=jpim) :: nflevg ! Total number of vertical levels integer(kind=jpim) :: nspec2 ! Number of spectral coefficients (real and imaginary) integer(kind=jpim) :: ngptot ! Total number of grid points on this task integer(kind=jpim) :: ngptotg ! Total number of grid points across all tasks integer(kind=jpim) :: ifld integer(kind=jpim) :: jroc integer(kind=jpim) :: jb integer(kind=jpim) :: nspec2g integer(kind=jpim) :: i integer(kind=jpim) :: ja integer(kind=jpim) :: ib integer(kind=jpim) :: jprtrv integer(kind=jpim), allocatable :: nprcids(:) integer(kind=jpim) :: myproc, jj integer :: jstep real(kind=jprd), external :: timef ! Timing routine from FIAT real(kind=jprd) :: ztinit, ztloop, ztstepmax, ztstepmin, ztstepavg, ztstepmed real(kind=jprd) :: ztstepmax1, ztstepmin1, ztstepavg1, ztstepmed1 real(kind=jprd) :: ztstepmax2, ztstepmin2, ztstepavg2, ztstepmed2 real(kind=jprd), allocatable :: ztstep(:), ztstep1(:), ztstep2(:) real(kind=jprb), allocatable :: znormvor(:), znormvor1(:), znormdiv(:), znormdiv1(:) real(kind=jprb), allocatable :: znormscalar(:), znormscalar1(:) real(kind=jprb), allocatable :: znormsc3a(:), znormsc3a1(:), znormsc2(:), znormsc21(:) real(kind=jprd) :: zaveave(0:jpmaxstat) ! Spectral space data structures real(kind=jprb), pointer :: zspvor(:,:) real(kind=jprb), pointer :: zspdiv(:,:) real(kind=jprb), pointer :: zspscalar(:,:) real(kind=jprb), pointer :: zspsc3a(:,:,:) real(kind=jprb), pointer :: zspsc2(:,:) ! Grid-point space data structures real(kind=jprb), pointer :: zgp(:,:,:) real(kind=jprb), pointer :: zgpuv(:,:,:,:) real(kind=jprb), pointer :: zgp3a(:,:,:,:) real(kind=jprb), pointer :: zgp2(:,:,:) logical :: lstack = .false. ! Output stack info ! setup_trans options integer(kind=jpim) :: nsmax = 79 ! Spectral truncation integer(kind=jpim) :: ndgl ! Number of latitudes integer(kind=jpim), allocatable :: nloen(:) ! Number of points on each latitude logical :: luserpnm = .false. ! Use Belusov algorithm to compute RPNM array instead of per m logical :: luseflt = .false. ! Use fast legendre transforms ! Extra inv_trans options logical :: lvordiv = .false. ! Compute vorticity and divergence in grid point space logical :: lscders = .false. ! Compute derivatives of scalar (North-South and East-West) in grid ! point space logical :: luvder = .false. ! Compute East-West derivatives of U and V wind in grid point space ! GSTATS options logical :: lstats = .true. ! gstats statistics logical :: ltrace_stats = .false. logical :: lstats_omp = .false. logical :: lstats_comms = .false. logical :: lbarrier_stats = .false. logical :: lbarrier_stats2 = .false. logical :: ldetailed_stats = .false. logical :: lstats_alloc = .false. logical :: lsyncstats = .false. logical :: lstatscpu = .false. logical :: lstats_mem = .false. logical :: lxml_stats = .false. integer(kind=jpim) :: nstats_mem = 0 integer(kind=jpim) :: ntrace_stats = 0 integer(kind=jpim) :: nprnt_stats = 1 integer(kind=jpim) :: nopt_mem_tr = 0 logical :: lprint_norms = .false. ! Calculate and print spectral norms logical :: lmeminfo = .false. ! Show information from FIAT routine ec_meminfo at the end ! The multiplier of the machine epsilon used as a tolerance for correctness checking ! ncheck = 0 (the default) means that correctness checking is disabled integer(kind=jpim) :: ncheck = 0 logical :: lmpoff = .false. ! Message passing switch ! Verbosity level (0 or 1) integer :: verbosity = 0 integer(kind=jpim) :: nproc ! Number of procs integer(kind=jpim) :: nthread integer(kind=jpim) :: nprgpns ! Grid-point decomp integer(kind=jpim) :: nprgpew ! Grid-point decomp integer(kind=jpim) :: nprtrv = 0 ! Spectral decomp integer(kind=jpim) :: nprtrw = 0 ! Spectral decomp integer(kind=jpim) :: mysetv integer(kind=jpim) :: mysetw integer(kind=jpim) :: mp_type = 2 ! Message passing type integer(kind=jpim) :: mbx_size = 150000000 ! Mailbox size integer(kind=jpim), allocatable :: numll(:), ivset(:), ivsetsc(:) integer(kind=jpim) :: ivsetsc2(1) integer(kind=jpim) :: nflevl ! sumpini integer(kind=jpim) :: isqr logical :: lsync_trans = .true. ! Activate barrier sync logical :: leq_regions = .true. ! Eq regions flag integer(kind=jpim) :: nproma = 0 integer(kind=jpim) :: npromatr = 0 integer(kind=jpim) :: ngpblks ! locals integer(kind=jpim) :: iprtrv integer(kind=jpim) :: iprtrw integer(kind=jpim) :: iprused, ilevpp, irest, ilev, jlev logical :: ldump_values = .false. logical :: lpinning = .false. logical :: ldump_checksums = .false. character(len=256) :: checksums_filename integer, external :: ec_mpirank logical :: luse_mpi = .true. character(len=16) :: cgrid = '' character(len=128) :: cchecksums_path = '' integer(kind=jpim) :: iend integer(kind=jpim) :: ierr integer :: icall_mode = 2 integer :: inum_wind_fields, inum_sc_3d_fields, inum_sc_2d_fields, itotal_fields integer :: ipgp_start, ipgp_end, ipgpuv_start, ipgpuv_end, islice real(kind=jprb), allocatable :: global_field(:,:) !=================================================================================================== #include "setup_trans0.h" #include "setup_trans.h" #include "inv_trans.h" #include "dir_trans.h" #include "trans_inq.h" #include "gath_grid.h" #include "gath_spec.h" #include "specnorm.h" #include "abor1.intfb.h" #include "gstats_setup.intfb.h" #include "ec_meminfo.intfb.h" #include "trans_end.h" !=================================================================================================== luse_mpi = detect_mpirun() if (VERSION == "gpu") then lpinning = .true. endif ! Setup call get_command_line_arguments(nsmax, cgrid, iters, iters_warmup, nfld, nlev, lvordiv, lscders, & & luvder, luseflt, nopt_mem_tr, nproma, npromatr, verbosity, & & ldump_values, lprint_norms, lmeminfo, nprtrv, nprtrw, ncheck, & & lpinning, icall_mode, ldump_checksums, cchecksums_path) if (cgrid == '') cgrid = cubic_octahedral_gaussian_grid(nsmax) call parse_grid(cgrid, ndgl, nloen) nflevg = nlev !=================================================================================================== if (luse_mpi) then call mpl_init(ldinfo=(verbosity>=1)) nproc = mpl_nproc() myproc = mpl_myrank() else nproc = 1 myproc = 1 mpl_comm = -1 lsync_trans = .false. endif nthread = oml_max_threads() call dr_hook_init() !=================================================================================================== if( lstats ) call gstats(0,0) ztinit = timef() ! only output to stdout on pe 1 if (nproc > 1) then if (myproc /= 1) then open(unit=nout, file='/dev/null') endif endif if (ldetailed_stats) then lstats_omp = .true. lstats_comms = .true. lstatscpu = .true. nprnt_stats = nproc endif !=================================================================================================== allocate(nprcids(nproc)) do jj = 1, nproc nprcids(jj) = jj enddo if (nproc <= 1) then lmpoff = .true. endif ! Compute nprgpns and nprgpew ! This version selects most square-like distribution ! These will change if leq_regions=.true. isqr = int(sqrt(real(nproc,jprb))) do ja = isqr, nproc ib = nproc/ja if (ja*ib == nproc) then nprgpns = max(ja,ib) nprgpew = min(ja,ib) exit endif enddo ! Compute nprtrv and nprtrw if not provided on the command line if (nprtrv > 0 .or. nprtrw > 0) then if (nprtrv == 0) nprtrv = nproc/nprtrw if (nprtrw == 0) nprtrw = nproc/nprtrv if (nprtrw*nprtrv /= nproc) call abor1('ectrans_benchmark:nprtrw*nprtrv /= nproc') else do jprtrv = 4, nproc nprtrv = jprtrv nprtrw = nproc/nprtrv if (nprtrv*nprtrw /= nproc) cycle if (nprtrv > nprtrw) exit enddo ! Go for approx square partition for backup if (nprtrv*nprtrw /= nproc .or. nprtrv > nprtrw) then isqr = int(sqrt(real(nproc,jprb))) do ja = isqr, nproc ib = nproc/ja if (ja*ib == nproc) then nprtrw = max(ja, ib) nprtrv = min(ja, ib) exit endif enddo endif endif ! Create communicators for mpi groups if (.not.lmpoff) then call mpl_groups_create(nprtrw, nprtrv) endif if (lmpoff) then mysetw = (myproc - 1)/nprtrv + 1 mysetv = mod(myproc - 1, nprtrv) + 1 else call mpl_cart_coords(myproc, mysetw, mysetv) ! Just checking for now... iprtrv = mod(myproc - 1, nprtrv) + 1 iprtrw = (myproc - 1)/nprtrv + 1 if (iprtrv /= mysetv .or. iprtrw /= mysetw) then call abor1('ectrans_benchmark:inconsistency when computing mysetw and mysetv') endif endif if (.not. lmpoff) then call mpl_buffer_method(kmp_type=mp_type, kmbx_size=mbx_size, kprocids=nprcids, ldinfo=(verbosity>=1)) endif ! Determine the number of levels attributed to each member of the V set allocate(numll(nprtrv)) iprused = min(nflevg+1, nprtrv) ilevpp = nflevg/nprtrv irest = nflevg -ilevpp*nprtrv do jroc = 1, nprtrv if (jroc <= irest) then numll(jroc) = ilevpp+1 else numll(jroc) = ilevpp endif enddo nflevl = numll(mysetv) ivsetsc2(1) = iprused ifld = 0 !=================================================================================================== ! Setup allocation strategy !=================================================================================================== if (verbosity >= 1 .and. myproc == 1) then call allocator%set_logging(.true.) call allocator%set_logging_output_unit(nout) endif call allocator%set_pinning(lpinning) !=================================================================================================== ! Setup gstats !=================================================================================================== if (lstats) then call gstats_setup(nproc, myproc, nprcids, & & lstats, lstatscpu, lsyncstats, ldetailed_stats, lbarrier_stats, lbarrier_stats2, & & lstats_omp, lstats_comms, lstats_mem, nstats_mem, lstats_alloc, & & ltrace_stats, ntrace_stats, nprnt_stats, lxml_stats) call gstats_psut ! Assign labels to GSTATS regions call gstats_labels endif !=================================================================================================== ! Call ecTrans setup routines !=================================================================================================== if (verbosity >= 1) write(nout,'(a)')'======= Setup ecTrans =======' call gstats(1, 0) call setup_trans0(kout=nout, kerr=nerr, kprintlev=merge(2, 0, verbosity == 1), kpromatr=npromatr, & & kprgpns=nprgpns, kprgpew=nprgpew, kprtrw=nprtrw, ldsync_trans=lsync_trans, & & ldeq_regions=leq_regions, ldalloperm=.true., ldmpoff=.not.luse_mpi, & & kopt_memory_tr=nopt_mem_tr) call gstats(1, 1) call gstats(2, 0) call setup_trans(ksmax=nsmax, kdgl=ndgl, kloen=nloen, ldsplit=.true., lduserpnm=luserpnm, & & lduseflt=luseflt) call gstats(2, 1) call trans_inq(kspec2=nspec2, kspec2g=nspec2g, kgptot=ngptot, kgptotg=ngptotg) if (nproma == 0) then ! no blocking (default when not specified) nproma = ngptot endif ! Calculate number of NPROMA blocks ngpblks = (ngptot - 1)/nproma+1 !=================================================================================================== ! Print information before starting !=================================================================================================== ! Print configuration details if (verbosity >= 0 .and. myproc == 1) then write(nout,'(" ")') write(nout,'(a)')'======= Start of runtime parameters =======' write(nout,'(" ")') write(nout,'("nsmax ",i0)') nsmax write(nout,'("grid ",a)') trim(cgrid) write(nout,'("ndgl ",i0)') ndgl write(nout,'("nproc ",i0)') nproc write(nout,'("nthread ",i0)') nthread write(nout,'("nprgpns ",i0)') nprgpns write(nout,'("nprgpew ",i0)') nprgpew write(nout,'("nprtrw ",i0)') nprtrw write(nout,'("nprtrv ",i0)') nprtrv write(nout,'("ngptot ",i0)') ngptot write(nout,'("ngptotg ",i0)') ngptotg write(nout,'("nfld ",i0)') nfld write(nout,'("nlev ",i0)') nlev write(nout,'("nproma ",i0)') nproma write(nout,'("npromatr ",i0)') npromatr write(nout,'("ngpblks ",i0)') ngpblks write(nout,'("nspec2 ",i0)') nspec2 write(nout,'("nspec2g ",i0)') nspec2g write(nout,'("luseflt ",l1)') luseflt write(nout,'("nopt_mem_tr",i0)') nopt_mem_tr write(nout,'("lvordiv ",l1)') lvordiv write(nout,'("lscders ",l1)') lscders write(nout,'("luvder ",l1)') luvder write(nout,'(" ")') write(nout,'(a)') '======= End of runtime parameters =======' write(nout,'(" ")') end if !=================================================================================================== ! Allocate and initialize spectral arrays !=================================================================================================== ! Compute spectral distribution variables for 3D fields allocate(ivset(nflevg)) ilev = 0 do jb = 1, nprtrv do jlev=1, numll(jb) ilev = ilev + 1 ivset(ilev) = jb enddo enddo ! Initialize vorticity and divergence - same for both call modes call allocator%allocate('zspvor', zspvor, [nflevl,nspec2]) call allocator%allocate('zspdiv', zspdiv, [nflevl,nspec2]) call initialize_spectral_field(nsmax, zspvor) call initialize_spectral_field(nsmax, zspdiv) ! Initialize spectral arrays differently depending on call mode if (icall_mode == 1) then ! Compute spectral distribution variables for call mode 1's combined 2D/3D spectral array allocate(ivsetsc(nfld*nflevg+1)) do i = 1, nfld ilev = 0 do jb = 1, nprtrv do jlev = 1, numll(jb) ilev = ilev + 1 ivsetsc(ilev + (i - 1)*nflevg) = jb enddo enddo enddo ivsetsc(nfld*nflevg+1) = 1 call allocator%allocate('zspscalar', zspscalar, [count(ivsetsc == mysetv),nspec2]) call initialize_spectral_field(nsmax, zspscalar) else call allocator%allocate('zspsc3a', zspsc3a, [nflevl,nspec2,nfld]) call allocator%allocate('zspsc2', zspsc2, [1,nspec2]) do i = 1, nfld call initialize_spectral_field(nsmax, zspsc3a(:,:,i)) enddo call initialize_spectral_field(nsmax, zspsc2) endif !=================================================================================================== ! Allocate gridpoint arrays !=================================================================================================== ! Determine start and end slice points for grid point arrays when they are passed back to dir_trans ipgp_start = 1 ipgp_end = (2 + nfld) * nflevg + 1 ipgpuv_start = 1 ipgpuv_end = 2 ! Also enable vorticity divergence? if (lvordiv) then inum_wind_fields = 4 ! Four fields - U, V, vorticity, divergence ! If lvordiv, skip the vorticity and divergence elements when passing zgp ! These two come first when enabled ipgp_start = ipgp_start + 2 * nflevg ipgp_end = ipgp_end + 2 * nflevg ipgpuv_start = ipgpuv_start + 2 ipgpuv_end = ipgpuv_end + 2 else ! Otherwise just U and V inum_wind_fields = 2 endif ! Also make room for East-West derivatives of winds? if (luvder) inum_wind_fields = inum_wind_fields + 2 ! We always have our nfld 3D scalar fields inum_sc_3d_fields = nfld ! We always have one 2D scalar field inum_sc_2d_fields = 1 ! Also make room for North-South and East-West derivatives of scalar fields if (lscders) then inum_sc_3d_fields = inum_sc_3d_fields * 3 inum_sc_2d_fields = inum_sc_2d_fields * 3 endif ! Finally, allocate grid point arrays if (icall_mode == 1) then itotal_fields = nflevg * (inum_wind_fields + inum_sc_3d_fields) + inum_sc_2d_fields call allocator%allocate('zgp', zgp, [nproma,itotal_fields,ngpblks]) else call allocator%allocate('zgpuv', zgpuv, [nproma,nflevg,inum_wind_fields,ngpblks]) call allocator%allocate('zgp3a', zgp3a, [nproma,nflevg,inum_sc_3d_fields,ngpblks]) call allocator%allocate('zgp2', zgp2, [nproma,inum_sc_2d_fields,ngpblks]) endif !=================================================================================================== ! Allocate norm arrays !=================================================================================================== if (lprint_norms .or. ncheck > 0) then allocate(znormvor(nflevg)) allocate(znormvor1(nflevg)) allocate(znormdiv(nflevg)) allocate(znormdiv1(nflevg)) call specnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor1, kvset=ivset) call specnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv1, kvset=ivset) if (icall_mode == 1) then allocate(znormscalar(nfld*nflevg+1)) allocate(znormscalar1(nfld*nflevg+1)) call specnorm(pspec=zspscalar(:,:), pnorm=znormscalar1, kvset=ivsetsc) else allocate(znormsc3a(nflevg)) allocate(znormsc3a1(nflevg)) allocate(znormsc2(1)) allocate(znormsc21(1)) if (nfld > 0) call specnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormsc3a1, kvset=ivset) call specnorm(pspec=zspsc2(1:1,:), pnorm=znormsc21, kvset=ivsetsc2) endif if (verbosity >= 1 .and. myproc == 1) then do ifld = 1, nflevg write(nout,'("norm zspvor( ",i4,",:) = ",f20.15)') ifld, znormvor1(ifld) write(nout,'("0x",Z16.16)') transfer(znormvor1(ifld),0_jpim) enddo do ifld = 1, nflevg write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15)') ifld, znormdiv1(ifld) write(nout,'("0x",Z16.16)') transfer(znormdiv1(ifld),0_jpim) enddo if (icall_mode == 1) then do ifld = 1, nfld*nflevg+1 write(nout,'("norm zspscalar(",i4,",:,1) = ",f20.15)') ifld, znormscalar1(ifld) write(nout,'("0x",Z16.16)') transfer(znormscalar1(ifld),0_jpim) enddo else if (nfld > 0) then do ifld = 1, nflevg write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15)') ifld, znormsc3a1(ifld) write(nout,'("0x",Z16.16)') transfer(znormsc3a1(ifld),0_jpim) enddo endif write(nout,'("norm zspsc2( ",i4,",:) = ",f20.15)') 1, znormsc21(1) write(nout,'("0x",Z16.16)') transfer(znormsc21(1),0_jpim) endif endif endif !=================================================================================================== ! Setup timers !=================================================================================================== ztinit = (timef() - ztinit)/1000.0_jprd if (verbosity >= 0 .and. myproc == 1) then write(nout,'(" ")') write(nout,'(a,i0,a,f9.2,a)') "ectrans_benchmark initialisation, on ",nproc,& & " tasks, took ",ztinit," sec" write(nout,'(" ")') endif if (iters <= 0) call abor1('ectrans_benchmark:iters <= 0') allocate(ztstep(iters+iters_warmup)) allocate(ztstep1(iters+iters_warmup)) allocate(ztstep2(iters+iters_warmup)) if (verbosity >= 1 .and. myproc == 1) then write(nout,'(a)') '======= Start of spectral transforms =======' write(nout,'(" ")') endif !=================================================================================================== ! Do spectral transform loop !=================================================================================================== gstats_lstats = .false. write(nout,'(a,i0,a,i0,a)') 'Running for ', iters, ' iterations with ', iters_warmup, & & ' extra warm-up iterations' write(nout,'(" ")') do jstep = 1, iters+iters_warmup if (jstep == iters_warmup + 1) then gstats_lstats = .true. ztloop = timef() endif call gstats(3,0) ztstep(jstep) = timef() !================================================================================================= ! Do inverse transform !================================================================================================= ztstep1(jstep) = timef() call gstats(4,0) if (icall_mode == 1) then call inv_trans(pspvor=zspvor, pspdiv=zspdiv, pspscalar=zspscalar, pgp=zgp, & & kvsetuv=ivset, kvsetsc=ivsetsc, & & ldscders=lscders, ldvorgp=lvordiv, lddivgp=lvordiv, lduvder=luvder, & & kproma=nproma) if (ldump_checksums) then ! Remove trash at end of last block iend = ngptot - nproma * (ngpblks - 1) zgp (iend+1:, :, ngpblks) = 0 write(checksums_filename,'(A)') trim(cchecksums_path)//'_inv_trans.checksums' call dump_checksums_pgp(filename=checksums_filename, noutdump=noutdump_checksum, jstep=jstep, & & myproc=myproc, nproma=nproma, ngptotg=ngptotg, zgp=zgp) endif else call inv_trans(pspvor=zspvor, pspdiv=zspdiv, pspsc3a=zspsc3a, pspsc2=zspsc2, pgpuv=zgpuv, & & pgp3a=zgp3a, pgp2=zgp2, & & kvsetuv=ivset, kvsetsc2=ivsetsc2, kvsetsc3a=ivset, & & ldscders=lscders, ldvorgp=lvordiv, lddivgp=lvordiv, lduvder=luvder, kproma=nproma) if (ldump_checksums) then ! Remove trash at end of last block iend = ngptot - nproma * (ngpblks - 1) zgpuv (iend+1:, :, :, ngpblks) = 0 zgp3a (iend+1:, :, :, ngpblks) = 0 zgp2 (iend+1:, :, ngpblks) = 0 write(checksums_filename,'(A)') trim(cchecksums_path)//'_inv_trans.checksums' call dump_checksums_pgp_uv_3a_2(filename=checksums_filename, noutdump=noutdump_checksum, jstep=jstep, & & myproc=myproc, nproma=nproma, ngptotg=ngptotg, zgpuv=zgpuv, zgp3a=zgp3a, & & zgp2=zgp2) endif endif call gstats(4,1) ztstep1(jstep) = (timef() - ztstep1(jstep))/1000.0_jprd !================================================================================================= ! While in grid point space, dump the values to disk, for debugging only !================================================================================================= if (ldump_values .and. mod(jstep,10) == 1) then ! dump a field to a binary file if (myproc == 1) then allocate(global_field(ngptotg,1)) endif if (icall_mode == 1) then islice = (ipgpuv_end - 1) * nflevg call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgp(:,islice:islice,:), 'U', noutdump) islice = ipgpuv_end * nflevg call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgp(:,islice:islice,:), 'V', noutdump) call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgp(:,ipgp_end:ipgp_end,:), 'S', noutdump) islice = ipgp_end - 1 call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgp(:,islice:islice,:), 'T', noutdump) else call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgpuv(:,nflevg:nflevg,1,:), 'U', noutdump) call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgpuv(:,nflevg:nflevg,2,:), 'V', noutdump) call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgp2(:,1:1,:), 'S', noutdump) call dump_gridpoint_field(jstep, myproc, nproma, global_field, zgp3a(:,nflevg:nflevg,1,:), 'T', noutdump) endif if (myproc == 1) then deallocate(global_field) endif endif !================================================================================================= ! Do direct transform !================================================================================================= ztstep2(jstep) = timef() call gstats(5,0) if (icall_mode == 1) then call dir_trans(pgp=zgp(:,ipgp_start:ipgp_end,:), pspvor=zspvor, pspdiv=zspdiv, & & pspscalar=zspscalar, kvsetuv=ivset, kvsetsc=ivsetsc, kproma=nproma) if (ldump_checksums) then write(checksums_filename,'(A)') trim(cchecksums_path)//'_dir_trans.checksums' call dump_checksums_psp(filename=checksums_filename, noutdump=noutdump_checksum, jstep=jstep, & & myproc=myproc, ivset=ivset, ivsetsc=ivsetsc, nspec2g=nspec2g, & & zspvor=zspvor, zspdiv=zspdiv, zspscalar=zspscalar) endif else call dir_trans(pgpuv=zgpuv(:,:,ipgpuv_start:ipgpuv_end,:), & & pgp3a=zgp3a(:,:,1:nfld,:), pgp2=zgp2(:,1:1,:), & & pspvor=zspvor, pspdiv=zspdiv, pspsc3a=zspsc3a, pspsc2=zspsc2, & & kvsetuv=ivset, kvsetsc2=ivsetsc2, kvsetsc3a=ivset, kproma=nproma) if (ldump_checksums) then write(checksums_filename,'(A)') trim(cchecksums_path)//'_dir_trans.checksums' call dump_checksums_psp_3a_2(filename=checksums_filename, noutdump=noutdump_checksum, jstep=jstep, & & myproc=myproc, ivset=ivset, ivsetsc2=ivsetsc2, nspec2g=nspec2g, & & zspvor=zspvor, zspdiv=zspdiv, zspsc3a=zspsc3a, zspsc2=zspsc2) endif endif call gstats(5,1) ztstep2(jstep) = (timef() - ztstep2(jstep))/1000.0_jprd ztstep(jstep) = (timef() - ztstep(jstep))/1000.0_jprd !================================================================================================= ! Print norms !================================================================================================= if (lprint_norms) then call gstats(6,0) call specnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset) call specnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset) if (icall_mode == 1) then call specnorm(pspec=zspscalar(:,:), pnorm=znormscalar, kvset=ivsetsc) else if (nfld > 0) call specnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormsc3a, kvset=ivset) call specnorm(pspec=zspsc2(1:1,:), pnorm=znormsc2, kvset=ivsetsc2) endif if (myproc == 1) then zmaxerr(1) = maxval(abs((znormvor1 / znormvor) - 1.0_jprb)) zmaxerr(2) = maxval(abs((znormdiv1 / znormdiv) - 1.0_jprb)) if (icall_mode == 1) then zmaxerr(3) = maxval(abs((znormscalar1 / znormscalar) - 1.0_jprb)) write(nout,'("time step ",i6," took", f8.4," | zspvor max err=",e10.3,& & " | zspdiv max err=",e10.3," | zspscalar max err=",e10.3)') & & jstep, ztstep(jstep), zmaxerr(1), zmaxerr(2), zmaxerr(3) else zmaxerr(4) = maxval(abs((znormsc21 / znormsc2) - 1.0_jprb)) if (nfld > 0) then zmaxerr(3) = maxval(abs((znormsc3a1 / znormsc3a) - 1.0_jprb)) write(nout,'("time step ",i6," took", f8.4," | zspvor max err=",e10.3,& & " | zspdiv max err=",e10.3," | zspsc3a max err=",e10.3," | zspsc2 max err=",e10.3)') & & jstep, ztstep(jstep), zmaxerr(1), zmaxerr(2), zmaxerr(3), zmaxerr(4) else write(nout,'("time step ",i6," took", f8.4," | zspvor max err=",e10.3,& & " | zspdiv max err=",e10.3," | zspsc2 max err=",e10.3)') & & jstep, ztstep(jstep), zmaxerr(1), zmaxerr(2), zmaxerr(4) endif endif endif call gstats(6,1) else write(nout,'("Time step ",i6," took", f8.4)') jstep, ztstep(jstep) endif call gstats(3,1) enddo !=================================================================================================== ztloop = (timef() - ztloop)/1000.0_jprd write(nout,'(" ")') write(nout,'(a)') '======= End of spectral transforms =======' write(nout,'(" ")') if (lprint_norms .or. ncheck > 0) then call specnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset) call specnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset) if (icall_mode == 1) then call specnorm(pspec=zspscalar(:,:), pnorm=znormscalar, kvset=ivsetsc) else if (nfld > 0) call specnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormsc3a, kvset=ivset) call specnorm(pspec=zspsc2(1:1,:), pnorm=znormsc2, kvset=ivsetsc2) endif if (myproc == 1) then zmaxerr = -99.0_jprd zmaxerr(1) = maxval(abs((real(znormvor1,jprd) / (real(znormvor,jprd)) - 1.0_jprd))) if (verbosity >= 1) then do ifld = 1, nflevg write(nout,'("norm zspvor( ",i4,") = ",f20.15)') ifld, znormvor(ifld) write(nout,'("0x",Z16.16)') transfer(znormvor(ifld), 0_jpim) enddo endif zmaxerr(2) = maxval(abs((real(znormdiv1,jprd) / (real(znormdiv,jprd)) - 1.0_jprd))) if (verbosity >= 1) then do ifld = 1, nflevg write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15)') ifld, znormdiv(ifld) write(nout,'("0x",Z16.16)') transfer(znormdiv(ifld), 0_jpim) enddo endif if (icall_mode == 1) then zmaxerr(3) = maxval(abs((znormscalar1 / znormscalar) - 1.0_jprb)) if (verbosity >= 1) then do ifld = 1, nfld*nflevg+1 write(nout,'("norm znormscalar( ",i4,",:) = ",f20.15)') ifld, znormscalar(ifld) write(nout,'("0x",Z16.16)') transfer(znormscalar(ifld), 0_jpim) enddo endif else zmaxerr(4) = maxval(abs((znormsc21 / znormsc2) - 1.0_jprb)) if (verbosity >= 1) then write(nout,'("norm znormsc2( ",i4,",:) = ",f20.15)') 1, znormsc2(1) write(nout,'("0x",Z16.16)') transfer(znormsc2(1), 0_jpim) endif if (nfld > 0) then zmaxerr(3) = maxval(abs((znormsc3a1 / znormsc3a) - 1.0_jprb)) if (verbosity >= 1) then do ifld = 1, nflevg write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15)') ifld, znormsc3a(ifld) write(nout,'("0x",Z16.16)') transfer(znormsc3a(ifld), 0_jpim) enddo endif endif endif ! maximum error across all fields zmaxerrg = maxval(zmaxerr) if (verbosity >= 1) write(nout,*) write(nout,'("max error zspvor(1:nlev,:) = ",e10.3)') zmaxerr(1) write(nout,'("max error zspdiv(1:nlev,:) = ",e10.3)') zmaxerr(2) if (icall_mode == 1) then write(nout,'("max error zspscalar(1:nlev,:,1) = ",e10.3)') zmaxerr(3) else if (nfld > 0) write(nout,'("max error zspsc3a(1:nlev,:,1) = ",e10.3)') zmaxerr(3) write(nout,'("max error zspsc2(1:1,:) = ",e10.3)') zmaxerr(4) endif write(nout,*) write(nout,'("max error combined = = ",e10.3)') zmaxerrg write(nout,*) endif if (ncheck > 0) then ierr = 0 if (myproc == 1) then ! If the maximum spectral norm error across all fields is greater than 100 times the machine ! epsilon, fail the test if (zmaxerrg > real(ncheck, jprb) * epsilon(1.0_jprb)) then write(nout, '(a)') '*******************************' write(nout, '(a)') 'Correctness test failed' write(nout, '(a,1e9.2)') 'Maximum spectral norm error = ', zmaxerrg write(nout, '(a,1e9.2)') 'Error tolerance = ', real(ncheck, jprb) * epsilon(1.0_jprb) write(nout, '(a)') '*******************************' ierr = 1 endif endif ! Root rank broadcasts the correctness checker result to the other ranks if (luse_mpi) then call mpl_broadcast(ierr,kroot=1,ktag=1) endif ! Halt if correctness checker failed if (ierr == 1) then error stop endif endif endif !=================================================================================================== ! Calculate timings !=================================================================================================== ztstepavg = sum(ztstep(iters_warmup+1:)) ztstepmin = minval(ztstep(iters_warmup+1:)) ztstepmax = maxval(ztstep(iters_warmup+1:)) ztstepavg1 = sum(ztstep1(iters_warmup+1:)) ztstepmin1 = minval(ztstep1(iters_warmup+1:)) ztstepmax1 = maxval(ztstep1(iters_warmup+1:)) ztstepavg2 = sum(ztstep2(iters_warmup+1:)) ztstepmin2 = minval(ztstep2(iters_warmup+1:)) ztstepmax2 = maxval(ztstep2(iters_warmup+1:)) if (luse_mpi) then call mpl_allreduce(ztloop, 'sum', ldreprod=.false.) call mpl_allreduce(ztstep, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin, 'min', ldreprod=.false.) call mpl_allreduce(ztstep1, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg1, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax1, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin1, 'min', ldreprod=.false.) call mpl_allreduce(ztstep2, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg2, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax2, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin2, 'min', ldreprod=.false.) endif ztstepavg = (ztstepavg/real(nproc,jprb))/real(iters,jprd) ztloop = ztloop/real(nproc,jprd) ztstep(:) = ztstep(:)/real(nproc,jprd) ztstepmed = get_median(ztstep(iters_warmup+1:)) ztstepavg1 = (ztstepavg1/real(nproc,jprb))/real(iters,jprd) ztstep1(:) = ztstep1(:)/real(nproc,jprd) ztstepmed1 = get_median(ztstep1(iters_warmup+1:)) ztstepavg2 = (ztstepavg2/real(nproc,jprb))/real(iters,jprd) ztstep2(:) = ztstep2(:)/real(nproc,jprd) ztstepmed2 = get_median(ztstep2(iters_warmup+1:)) write(nout,'(a)') '======= Start of time step stats =======' write(nout,'(" ")') write(nout,'("Inverse transforms")') write(nout,'("------------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg1 write(nout,'("min (s): ",f8.4)') ztstepmin1 write(nout,'("max (s): ",f8.4)') ztstepmax1 write(nout,'("med (s): ",f8.4)') ztstepmed1 write(nout,'(" ")') write(nout,'("Direct transforms")') write(nout,'("-----------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg2 write(nout,'("min (s): ",f8.4)') ztstepmin2 write(nout,'("max (s): ",f8.4)') ztstepmax2 write(nout,'("med (s): ",f8.4)') ztstepmed2 write(nout,'(" ")') write(nout,'("Inverse-direct transforms")') write(nout,'("-------------------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg write(nout,'("min (s): ",f8.4)') ztstepmin write(nout,'("max (s): ",f8.4)') ztstepmax write(nout,'("med (s): ",f8.4)') ztstepmed write(nout,'("loop (s): ",f8.4)') ztloop write(nout,'(" ")') write(nout,'(a)') '======= End of time step stats =======' write(nout,'(" ")') if (lstack) then ! Gather stack usage statistics istack = getstackusage() if (myproc == 1) then print 9000, istack 9000 format("Stack utilisation information",/,& &"=============================",//,& &"Task size(bytes)",/,& &"==== ===========",//,& &" 1",11x,i10) do i = 2, nproc call mpl_recv(istack, ksource=nprcids(i), ktag=i, cdstring='ectrans_benchmark:') print '(i4,11x,i10)', i, istack enddo else call mpl_send(istack, kdest=nprcids(1), ktag=myproc, cdstring='ectrans_benchmark:') endif endif !=================================================================================================== ! Cleanup !=================================================================================================== call allocator%deallocate('zspvor', zspvor) call allocator%deallocate('zspdiv', zspdiv) if (icall_mode == 1) then call allocator%deallocate('zspscalar', zspscalar) else call allocator%deallocate('zspsc3a', zspsc3a) call allocator%deallocate('zspsc2', zspsc2) endif if (icall_mode == 1) then call allocator%deallocate('zgp', zgp) else call allocator%deallocate('zgpuv', zgpuv) call allocator%deallocate('zgp3a', zgp3a) call allocator%deallocate('zgp2', zgp2) endif !=================================================================================================== if (lstats) then call gstats(0,1) call gstats_print(nout, zaveave, jpmaxstat) endif if (lmeminfo) then write(nout,*) call ec_meminfo(nout, "", mpl_comm, kbarr=1, kiotask=-1, & & kcall=1) endif call trans_end !=================================================================================================== ! Finalize MPI !=================================================================================================== if (luse_mpi) then call mpl_end(ldmeminfo=.false.) endif !=================================================================================================== ! Close file !=================================================================================================== if (nproc > 1) then if (myproc /= 1) then close(unit=nout) endif endif !=================================================================================================== contains !=================================================================================================== subroutine parse_grid(cgrid,ndgl,nloen) character(len=*), intent(in) :: cgrid integer, intent(inout) :: ndgl integer, intent(inout), allocatable :: nloen(:) integer :: ios integer :: gaussian_number integer :: i read(cgrid(2:len_trim(cgrid)),*,IOSTAT=ios) gaussian_number if (ios==0) then ndgl = 2 * gaussian_number allocate(nloen(ndgl)) if (cgrid(1:1) == 'F') then ! Regular Gaussian grid nloen(:) = gaussian_number * 4 return endif if (cgrid(1:1) == 'O') then ! Octahedral Gaussian grid do i = 1, ndgl / 2 nloen(i) = 20 + 4 * (i - 1) nloen(ndgl - i + 1) = nloen(i) end do return endif endif call parsing_failed("ERROR: Unsupported grid specified: "// trim(cgrid)) end subroutine !=================================================================================================== subroutine str2int(str, int, stat) character(len=*), intent(in) :: str integer, intent(out) :: int integer, intent(out) :: stat read(str, *, iostat=stat) int end subroutine str2int !=================================================================================================== function get_int_value(cname, iarg) result(value) integer :: value character(len=*), intent(in) :: cname integer, intent(inout) :: iarg character(len=128) :: carg integer :: stat carg = get_str_value(cname, iarg) call str2int(carg, value, stat) if (stat /= 0) then call parsing_failed("Invalid argument for " // trim(cname) // ": " // trim(carg)) end if end function !=================================================================================================== function get_str_value(cname, iarg) result(value) character(len=128) :: value character(len=*), intent(in) :: cname integer, intent(inout) :: iarg iarg = iarg + 1 call get_command_argument(iarg, value) if (value == "") then call parsing_failed("Invalid argument for " // trim(cname) // ": no value provided") end if end function !=================================================================================================== subroutine print_help(unit) integer, optional :: unit integer :: nout if (present(unit)) then nout = unit else nout = 6 endif write(nout, "(a)") "" if (jprb == jprd) then write(nout, "(a)") "NAME ectrans-benchmark-" // VERSION // "-dp" else write(nout, "(a)") "NAME ectrans-benchmark-" // VERSION // "-sp" end if write(nout, "(a)") "" write(nout, "(a)") "DESCRIPTION" write(nout, "(a)") " This program tests ecTrans by transforming fields back and forth& & between spectral " if (jprb == jprd) then write(nout, "(a)") " space and grid-point space (double-precision version)" else write(nout, "(a)") " space and grid-point space (single-precision version)" end if write(nout, "(a)") "" write(nout, "(a)") "USAGE" if (jprb == jprd) then write(nout, "(a)") " ectrans-benchmark-" // VERSION // "-dp [options]" else write(nout, "(a)") " ectrans-benchmark-" // VERSION // "-sp [options]" end if write(nout, "(a)") "" write(nout, "(a)") "OPTIONS" write(nout, "(a)") " -h, --help Print this message" write(nout, "(a)") " -v Run with verbose output" write(nout, "(a)") " -t, --truncation T Run with this triangular spectral truncation& & (default = 79)" write(nout, "(a)") " -g, --grid GRID Run with this grid. Possible values: O, F" write(nout, "(a)") " If not specified, O is used with N=truncation+1& & (cubic relation)" write(nout, "(a)") " -n, --niter NITER Run for this many inverse/direct transform& & iterations (default = 10)" write(nout, "(a)") " --niter-warmup Number of warm up iterations,& & for which timing statistics should be ignored (default = 3)" write(nout, "(a)") " -f, --nfld NFLD Number of scalar fields (default = 1)" write(nout, "(a)") " -l, --nlev NLEV Number of vertical levels (default = 1)" write(nout, "(a)") " --vordiv Also transform vorticity-divergence to wind" write(nout, "(a)") " --scders Compute scalar derivatives (default off)" write(nout, "(a)") " --uvders Compute uv East-West derivatives (default off). Only& & when also --vordiv is given" write(nout, "(a)") " --flt Run with fast Legendre transforms (default off)" write(nout, "(a)") " --nproma NPROMA Run with NPROMA (default no blocking: NPROMA=ngptot)" write(nout, "(a)") " --npromatr NPROMATR Perform transforms in blocks of size NPROMATR rather& & than all at once" write(nout, "(a)") " --norms Calculate and print spectral norms of transformed& & fields" write(nout, "(a)") " The computation of spectral norms will skew overall& & timings" write(nout, "(a)") " --meminfo Show diagnostic information from FIAT's ec_meminfo& & subroutine on memory usage, thread-binding etc." write(nout, "(a)") " --nprtrv Size of V set in spectral decomposition" write(nout, "(a)") " --nprtrw Size of W set in spectral decomposition" write(nout, "(a)") " -c, --check VALUE The multiplier of the machine epsilon used as a& & tolerance for correctness checking" write(nout, "(a)") " --no-pinning Disable memory-pinning (a.k.a. page-locked memory) & & to allocate fields for GPU version" write(nout, "(a)") " --callmode The call mode for INV_TRANS and DIR_TRANS (1 or 2)" write(nout, "(a)") " Call mode 1 uses arrays PSPVOR, PSPDIV, PSPSCALAR and& & PGP" write(nout, "(a)") " Call mode 2 uses arrays PSPVOR, PSPDIV, PSPSC3A,& & PSPSC3B, PSPSC2, PGPUV, PGP3A, PGP3B, PGP2" write(nout, "(a)") " See& & https://sites.ecmwf.int/docs/ectrans/page/api.html for more information (default = 2)" write(nout, "(a)") "" write(nout, "(a)") "DEBUGGING" write(nout, "(a)") " --dump-values Output gridpoint fields in unformatted binary file" write(nout, "(a)") " --dump-checksums FILENAME Output CRC64 checksums of fields in text file named FILENAME" write(nout, "(a)") "" end subroutine print_help !=================================================================================================== subroutine parsing_failed(message) character(len=*), intent(in) :: message if (luse_mpi) call mpl_init(ldinfo=.false.) if (ec_mpirank() == 0) then write(nerr,"(a)") trim(message) call print_help(unit=nerr) endif if (luse_mpi) call mpl_end(ldmeminfo=.false.) error stop end subroutine !=================================================================================================== subroutine get_command_line_arguments(nsmax, cgrid, iters, iters_warmup, nfld, nlev, lvordiv, & & lscders, luvder, luseflt, nopt_mem_tr, nproma, npromatr, & & verbosity, ldump_values, lprint_norms, lmeminfo, nprtrv, & & nprtrw, ncheck, lpinning, icall_mode, ldump_checksums, & & cchecksums_path) #ifdef _OPENACC use openacc, only: acc_init, acc_get_device_type #endif integer, intent(inout) :: nsmax ! Spectral truncation character(len=16), intent(inout) :: cgrid ! Grid integer, intent(inout) :: iters ! Number of iterations for transform test integer, intent(inout) :: iters_warmup ! Number of iterations for transform test integer, intent(inout) :: nfld ! Number of scalar fields integer, intent(inout) :: nlev ! Number of vertical levels logical, intent(inout) :: lvordiv ! Also transform vorticity/divergence logical, intent(inout) :: lscders ! Compute scalar derivatives logical, intent(inout) :: luvder ! Compute uv East-West derivatives logical, intent(inout) :: luseflt ! Use fast Legendre transforms integer, intent(inout) :: nopt_mem_tr ! Use of heap or stack memory for ZCOMBUF arrays in transposition arrays (0 for heap, 1 for stack) integer, intent(inout) :: nproma ! NPROMA integer, intent(inout) :: npromatr ! block size for field-blocking integer, intent(inout) :: verbosity ! Level of verbosity logical, intent(inout) :: ldump_values ! Dump values of grid point fields for debugging logical, intent(inout) :: ldump_checksums ! Dump CRC checksums logical, intent(inout) :: lprint_norms ! Calculate and print spectral norms of fields logical, intent(inout) :: lmeminfo ! Show information from FIAT ec_meminfo routine at the ! end integer, intent(inout) :: nprtrv ! Size of V set (spectral decomposition) integer, intent(inout) :: nprtrw ! Size of W set (spectral decomposition) integer, intent(inout) :: ncheck ! The multiplier of the machine epsilon used as a ! tolerance for correctness checking logical, intent(inout) :: lpinning ! Use memory-pinning (a.k.a. page-locked memory) to allocate fields for GPU version integer, intent(inout) :: icall_mode ! The call mode for inv_trans and dir_trans ! 1: pspvor, pspdiv, pspscalar, pgp ! 2: pspvor, pspdiv, pspsc3a, pspsc2, pgpuv, pgp3a, pgp2 character(len=128), intent(inout) :: cchecksums_path ! path to export checksum files character(len=128) :: carg ! Storage variable for command line arguments integer :: iarg ! Argument index #ifdef _OPENACC call acc_init(acc_get_device_type()) #endif iarg = 1 do while (iarg <= command_argument_count()) call get_command_argument(iarg, carg) select case(carg) ! Parse help argument case('-h', '--help') if (luse_mpi) call mpl_init(ldinfo=.false.) if (ec_mpirank()==0) call print_help() if (luse_mpi) call mpl_end(ldmeminfo=.false.) stop ! Parse verbosity argument case('-v') verbosity = 1 ! Parse number of iterations argument case('-n', '--niter') iters = get_int_value('-n', iarg) if (iters < 1) then call parsing_failed("Invalid argument for -n: must be > 0") end if case('--niter-warmup') iters_warmup = get_int_value('--niter-warmup', iarg) if (iters_warmup < 0) then call parsing_failed("Invalid argument for --niter-warmup: must be >= 0") end if ! Parse spectral truncation argument case('-t', '--truncation') nsmax = get_int_value('-t', iarg) if (nsmax < 1) then call parsing_failed("Invalid argument for -t: must be > 0") end if case('-g', '--grid'); cgrid = get_str_value('-g', iarg) case('-f', '--nfld'); nfld = get_int_value('-f', iarg) case('-l', '--nlev'); nlev = get_int_value('-l', iarg) case('--vordiv'); lvordiv = .true. case('--scders'); lscders = .true. case('--uvders'); luvder = .true. case('--flt'); luseflt = .true. case('--mem-tr'); nopt_mem_tr = get_int_value('--mem-tr', iarg) case('--nproma'); nproma = get_int_value('--nproma', iarg) case('--npromatr'); npromatr = get_int_value('--npromatr', iarg) case('--dump-values'); ldump_values = .true. case('--dump-checksums') ldump_checksums = .true. cchecksums_path = get_str_value('--dump-checksums', iarg) case('--norms'); lprint_norms = .true. case('--meminfo'); lmeminfo = .true. case('--nprtrv'); nprtrv = get_int_value('--nprtrv', iarg) case('--nprtrw'); nprtrw = get_int_value('--nprtrw', iarg) case('-c', '--check'); ncheck = get_int_value('-c', iarg) case('--no-pinning'); lpinning = .False. case('--callmode') icall_mode = get_int_value('--callmode', iarg) if (icall_mode /= 1 .and. icall_mode /= 2) then call parsing_failed("Invalid argument for --callmode: must be 1 or 2") end if case default call parsing_failed("Unrecognised argument: " // trim(carg)) end select iarg = iarg + 1 end do end subroutine get_command_line_arguments !=================================================================================================== function cubic_octahedral_gaussian_grid(nsmax) result(cgrid) character(len=16) :: cgrid integer, intent(in) :: nsmax write(cgrid,'(a,i0)') 'O',nsmax+1 end function !=================================================================================================== function get_median(vec) result(median) real(kind=jprd), intent(in) :: vec(:) real(kind=jprd) :: median real(kind=jprd) :: vec_sorted(size(vec)) real(kind=jprd) :: x integer :: i, j, n n = size(vec) ! Sort in ascending order vec_sorted = vec do i = 2, n x = vec_sorted(i) j = i - 1 do while (j >= 1) if (vec_sorted(j) <= x) exit vec_sorted(j + 1) = vec_sorted(j) j = j - 1 end do vec_sorted(j + 1) = x end do ! Calculate median according to if there is an even or odd number of elements if (mod(n, 2) == 0) then median = (vec_sorted(n/2) + vec_sorted(n/2+1))/2.0_jprd else median = vec_sorted((n+1)/2) endif end function get_median !=================================================================================================== subroutine initialize_spectral_field(nsmax, field) integer, intent(in) :: nsmax ! Spectral truncation real(kind=jprb), intent(inout) :: field(:,:) ! Field to initialize integer :: i do i = 1, size(field,1) call initialize_2d_spectral_field(nsmax, field(i,:)) enddo end subroutine initialize_spectral_field !=================================================================================================== subroutine initialize_2d_spectral_field(nsmax, field) integer, intent(in) :: nsmax ! Spectral truncation real(kind=jprb), intent(inout) :: field(:) ! Field to initialize integer :: num_my_zon_wns integer, allocatable :: my_zon_wns(:) ! Choose a spherical harmonic to initialize arrays integer, parameter :: m_num = 4 ! Zonal wavenumber integer, parameter :: l_num = 19 ! Total wavenumber ! First initialise all spectral coefficients to zero field(:) = 0.0 ! Get zonal wavenumbers this rank is responsible for call trans_inq(knump=num_my_zon_wns) allocate(my_zon_wns(num_my_zon_wns)) call trans_inq(kmyms=my_zon_wns) ! If rank is responsible for the chosen zonal wavenumber... if (any(my_zon_wns == m_num) ) then block integer, allocatable :: nasm0(:) integer :: index ! Get array of spectral array addresses (this maps (m, n=m) to array index) allocate(nasm0(0:nsmax)) call trans_inq(kasm0=nasm0) ! Find out local array index of chosen spherical harmonic index = nasm0(m_num) + 2 * (l_num - m_num) + 1 ! Set just that element to a constant value field(index) = 1.0 end block end if end subroutine initialize_2d_spectral_field !=================================================================================================== subroutine dump_gridpoint_field(jstep, myproc, nproma, gfld, fld, fldchar, noutdump) ! Dump a 2d field to a binary file. integer(kind=jpim), intent(in) :: jstep ! Time step, used for naming file integer(kind=jpim), intent(in) :: myproc ! MPI rank, used for naming file integer(kind=jpim), intent(in) :: nproma ! Size of nproma real(kind=jprb) , intent(inout) :: gfld(:,:) ! 2d global field real(kind=jprb) , intent(in) :: fld(:,:,:) ! 3d local field character , intent(in) :: fldchar ! Single character field identifier integer(kind=jpim), intent(in) :: noutdump ! unit number for output file character(len=10) :: filename integer(kind=jpim) :: ilev filename = "x.xxxx.dat" if (myproc == 1) then write(filename(1:1),'(a1)') fldchar write(filename(3:6),'(i4.4)') jstep open(noutdump,file=filename,form='unformatted') endif do ilev=1,size(fld,2) call gath_grid(gfld(:,:),nproma,1,(/1/),1,fld(:,ilev:ilev,:)) if (myproc == 1) write(unit=noutdump) gfld(:,1) enddo if (myproc == 1) then close(noutdump) endif end subroutine dump_gridpoint_field !=================================================================================================== subroutine open_dump_checksums_file(filename, noutdump, jstep) character(len=*), intent(in) :: filename integer(kind=jpim), intent(in) :: noutdump ! unit number for output file integer(kind=jpim), intent(in) :: jstep logical :: exist exist = .false. if (jstep > 1) inquire(file=trim(filename), exist=exist) if (exist) then write(nout,*) "re-opening ", trim(filename), noutdump open(noutdump, file=trim(filename), status="old", position="append", action="write") else write(nout,*) "opening ", trim(filename), noutdump open(noutdump, file=trim(filename), action="write") endif write(noutdump,*) "====================" write(noutdump,*) "iteration", jstep write(noutdump,*) "====================" end subroutine open_dump_checksums_file !=================================================================================================== subroutine dump_checksums_pgp(filename, noutdump, & & jstep, myproc, nproma, ngptotg, & & zgp) character(len=*), intent(in) :: filename integer(kind=jpim), intent(in) :: noutdump ! unit number for output file integer(kind=jpim), intent(in) :: jstep ! time step integer(kind=jpim), intent(in) :: myproc ! mpi rank integer(kind=jpim), intent(in) :: nproma ! size of nproma integer(kind=jpim), intent(in) :: ngptotg real(kind=jprb), intent(in) :: zgp(:,:,:) integer(kind=jpib) :: icrc integer(kind=jpim) :: jfld real(kind=jprb), allocatable :: gfld(:,:) if (myproc == 1) then call open_dump_checksums_file(filename, noutdump, jstep) allocate(gfld(ngptotg,1)) endif icrc = 0 do jfld = 1, size(zgp, 2) call gath_grid(pgpg=gfld, kproma=nproma, kfgathg=1, kto=(/1/), kresol=1, & & pgp=zgp(:,jfld:jfld,:)) if (myproc == 1) then call crc64(gfld(:,:), int(size(gfld(:,:)) * kind(gfld), 8), icrc) write(noutdump, '(a," (",i0,") = ",z16.16)') "zgp", jfld, icrc endif enddo if (myproc == 1) then write(nout,*) "close ", noutdump close(noutdump) if (allocated(gfld)) deallocate(gfld) endif end subroutine dump_checksums_pgp !=================================================================================================== subroutine dump_checksums_pgp_uv_3a_2(filename, noutdump, & & jstep, myproc, nproma, ngptotg, & & zgpuv, zgp3a, zgp2) character(len=*), intent(in) :: filename integer(kind=jpim), intent(in) :: noutdump ! unit number for output file integer(kind=jpim), intent(in) :: jstep ! time step integer(kind=jpim), intent(in) :: myproc ! mpi rank integer(kind=jpim), intent(in) :: nproma ! size of nproma integer(kind=jpim), intent(in) :: ngptotg real(kind=jprb), intent(in) :: zgpuv(:,:,:,:) real(kind=jprb), intent(in) :: zgp3a(:,:,:,:) real(kind=jprb), intent(in) :: zgp2(:,:,:) integer(kind=jpib) :: icrc integer(kind=jpim) :: jlev, jfld real(kind=jprb), allocatable :: gfld(:,:) if (myproc == 1) then call open_dump_checksums_file(filename, noutdump, jstep) allocate(gfld(ngptotg,1)) endif icrc = 0 do jfld = 1, size(zgpuv, 3) do jlev = 1, size(zgpuv, 2) call gath_grid(pgpg=gfld, kproma=nproma, kfgathg=1, kto=(/1/), kresol=1, & & pgp=zgpuv(:,jlev:jlev,jfld,:)) if (myproc == 1) then call crc64(gfld(:,:), int(size(gfld(:,:)) * kind(gfld), 8), icrc) write(noutdump, '(a," (",i0,", ",i0,") = ",z16.16)') "zgpuv", jlev, jfld, icrc endif enddo enddo icrc = 0 do jfld = 1, size(zgp3a, 3) do jlev = 1, size(zgp3a, 2) call gath_grid(pgpg=gfld, kproma=nproma, kfgathg=1, kto=(/1/), kresol=1, & & pgp=zgp3a(:,jlev:jlev,jfld,:)) if (myproc == 1) then call crc64(gfld(:,:), int(size(gfld(:,:)) * kind(gfld), 8), icrc) write(noutdump, '(a," (",i0,", ",i0,") = ",z16.16)') "zgp3a", jlev, jfld, icrc endif enddo enddo icrc = 0 do jfld = 1, size(zgp2, 2) call gath_grid(pgpg=gfld, kproma=nproma, kfgathg=1, kto=(/1/), kresol=1, & & pgp=zgp2(:,jfld:jfld,:)) if (myproc == 1) then call crc64(gfld(:,:), int(size(gfld(:,:)) * kind(gfld), 8), icrc) write(noutdump, '(a," (",i0,") = ",z16.16)') "zgp2", jfld, icrc endif enddo if (myproc == 1) then write(nout,*) "close ", noutdump close(noutdump) if (allocated(gfld)) deallocate(gfld) endif end subroutine dump_checksums_pgp_uv_3a_2 !=================================================================================================== subroutine dump_checksums_psp(filename, noutdump, & & jstep, myproc, nspec2g, & & ivset, ivsetsc, & & zspvor, zspdiv, zspscalar) character(len=*), intent(in) :: filename integer(kind=jpim), intent(in) :: noutdump ! unit number for output file integer(kind=jpim), intent(in) :: jstep ! time step integer(kind=jpim), intent(in) :: myproc ! mpi rank integer(kind=jpim), intent(in) :: nspec2g integer(kind=jpim), intent(in) :: ivset(:) integer(kind=jpim), intent(in) :: ivsetsc(:) real(kind=jprb), intent(in) :: zspvor(:,:) real(kind=jprb), intent(in) :: zspdiv(:,:) real(kind=jprb), intent(in) :: zspscalar(:,:) integer(kind=jpim) :: numfld integer(kind=jpib) :: icrc real(kind=jprb), allocatable :: gspfld(:,:) if (myproc == 1) then call open_dump_checksums_file(filename, noutdump, jstep) allocate(gspfld(max(size(ivset), size(ivsetsc)), nspec2g)) endif numfld = size(ivset) if (myproc == 1) then call gath_spec(pspecg=gspfld(1:numfld,:), kfgathg=numfld, kto=[(1, i = 1, numfld)], & & kvset=ivset, pspec=zspvor) icrc = 0 call crc64(gspfld(1:numfld,:), int(size(gspfld(1:numfld,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a," = ",z16.16)') "zspvor", icrc else call gath_spec(kfgathg=numfld, kto=[(1, i = 1, numfld)], kvset=ivset, pspec=zspvor) endif if (myproc == 1) then call gath_spec(pspecg=gspfld(1:numfld,:), kfgathg=numfld, kto=[(1, i = 1, numfld)], & & kvset=ivset, pspec=zspdiv) icrc = 0 call crc64(gspfld(1:numfld,:), int(size(gspfld(1:numfld,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a," = ",z16.16)') "zspdiv", icrc else call gath_spec(kfgathg=numfld, kto=[(1, i = 1, numfld)], kvset=ivset, pspec=zspdiv) endif numfld = size(ivsetsc) if (myproc == 1) then call gath_spec(pspecg=gspfld(1:numfld,:), kfgathg=numfld, kto=[(1, i = 1, numfld)], & & kvset=ivsetsc, pspec=zspscalar) icrc = 0 call crc64(gspfld(1:numfld,:), int(size(gspfld(1:numfld,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a," = ",z16.16)') "zspscalar", icrc else call gath_spec(kfgathg=numfld, kto=[(1, i = 1, numfld)], kvset=ivsetsc, pspec=zspscalar) endif if (myproc == 1) then write(nout,*) "close ", noutdump close(noutdump) if (allocated(gspfld)) deallocate(gspfld) endif end subroutine dump_checksums_psp !=================================================================================================== subroutine dump_checksums_psp_3a_2(filename, noutdump, & & jstep, myproc, nspec2g, & & ivset, ivsetsc2, & & zspvor, zspdiv, & & zspsc3a, zspsc2) character(len=*), intent(in) :: filename integer(kind=jpim), intent(in) :: noutdump ! unit number for output file integer(kind=jpim), intent(in) :: jstep ! time step integer(kind=jpim), intent(in) :: myproc ! mpi rank integer(kind=jpim), intent(in) :: nspec2g integer(kind=jpim), intent(in) :: ivset(:) integer(kind=jpim), intent(in) :: ivsetsc2(:) real(kind=jprb), intent(in) :: zspvor(:,:) real(kind=jprb), intent(in) :: zspdiv(:,:) real(kind=jprb), intent(in) :: zspsc3a(:,:,:) real(kind=jprb), intent(in) :: zspsc2(:,:) integer(kind=jpim) :: numfld, jfld integer(kind=jpib) :: icrc real(kind=jprb), allocatable :: gspfld(:,:) if (myproc == 1) then call open_dump_checksums_file(filename, noutdump, jstep) allocate(gspfld(max(size(ivset), 1), nspec2g)) ! size(ivsetsc2) is always 1 endif numfld = size(ivset) if (myproc == 1) then call gath_spec(pspecg=gspfld(1:numfld,:), kfgathg=numfld, kto=[(1, i = 1, numfld)], & & kvset=ivset, pspec=zspvor) icrc = 0 call crc64(gspfld(1:numfld,:), int(size(gspfld(1:numfld,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a," = ",z16.16)') "zspvor", icrc else call gath_spec(kfgathg=numfld, kto=[(1, i = 1, numfld)], kvset=ivset, pspec=zspvor) endif if (myproc == 1) then call gath_spec(pspecg=gspfld(1:numfld,:), kfgathg=numfld, kto=[(1, i = 1, numfld)], & & kvset=ivset, pspec=zspdiv) icrc = 0 call crc64(gspfld(1:numfld,:), int(size(gspfld(1:numfld,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a," = ",z16.16)') "zspdiv", icrc else call gath_spec(kfgathg=numfld, kto=[(1, i = 1, numfld)], kvset=ivset, pspec=zspdiv) endif do jfld = 1, size(zspsc3a, 3) if (myproc == 1) then call gath_spec(pspecg=gspfld(1:numfld,:), kfgathg=numfld, kto=[(1, i = 1, numfld)], & & kvset=ivset, pspec=zspsc3a(:,:,jfld)) icrc = 0 call crc64(gspfld(1:numfld,:), int(size(gspfld(1:numfld,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a,"(",i0,") = ",z16.16)') "zspsc3a", jfld, icrc else call gath_spec(kfgathg=numfld, kto=[(1, i = 1, numfld)], kvset=ivset, pspec=zspsc3a(:,:,jfld)) endif enddo if (myproc == 1) then call gath_spec(pspecg=gspfld(1:1,:), kfgathg=1, kto=[1], kvset=ivsetsc2, pspec=zspsc2) icrc = 0 call crc64(gspfld(1,:), int(size(gspfld(1,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a," = ",z16.16)') "zspsc2", icrc else call gath_spec(kfgathg=1, kto=[1], kvset=ivsetsc2, pspec=zspsc2) endif if (myproc == 1) then write(nout,*) "close ", noutdump close(noutdump) if (allocated(gspfld)) deallocate(gspfld) endif end subroutine dump_checksums_psp_3a_2 !=================================================================================================== function detect_mpirun() result(lmpi_required) use ec_env_mod, only : ec_putenv logical :: lmpi_required integer :: ilen integer, parameter :: nvars = 4 character(len=32), dimension(nvars) :: cmpirun_detect character(len=4) :: clenv integer :: ivar ! Environment variables that are set when mpirun, srun, aprun, ... are used cmpirun_detect(1) = 'OMPI_COMM_WORLD_SIZE' ! openmpi cmpirun_detect(2) = 'ALPS_APP_PE' ! cray pe cmpirun_detect(3) = 'PMI_SIZE' ! intel cmpirun_detect(4) = 'SLURM_NTASKS' ! slurm lmpi_required = .false. do ivar = 1, nvars call get_environment_variable(name=trim(cmpirun_detect(ivar)), length=ilen) if (ilen > 0) then lmpi_required = .true. exit ! break endif enddo call get_environment_variable(name="ECTRANS_USE_MPI", value=clenv, length=ilen ) if (ilen > 0) then lmpi_required = .true. if( trim(clenv) == "0" .or. trim(clenv) == "OFF" .or. trim(CLENV) == "off" .or. trim(clenv) == "F" ) then lmpi_required = .false. endif call ec_putenv("DR_HOOK_ASSERT_MPI_INITIALIZED=0", overwrite=.true.) endif end function !=================================================================================================== ! Assign GSTATS labels to the main regions of ecTrans subroutine gstats_labels call gstats_label(0, ' ', 'PROGRAM - Total') call gstats_label(1, ' ', 'SETUP_TRANS0 - Setup ecTrans') call gstats_label(2, ' ', 'SETUP_TRANS - Setup ecTrans handle') call gstats_label(3, ' ', 'TIME STEP - Time step') call gstats_label(4, ' ', 'INV_TRANS - Inverse transform') call gstats_label(5, ' ', 'DIR_TRANS - Direct transform') call gstats_label(6, ' ', 'NORMS - Norm comp. (optional)') call gstats_label(102, ' ', 'LTINV_CTL - Inv. Legendre transform') call gstats_label(103, ' ', 'LTDIR_CTL - Dir. Legendre transform') call gstats_label(106, ' ', 'FTDIR_CTL - Dir. Fourier transform') call gstats_label(107, ' ', 'FTINV_CTL - Inv. Fourier transform') call gstats_label(140, ' ', 'SULEG - Comp. of Leg. poly.') call gstats_label(152, ' ', 'LTINV_CTL - M to L transposition') call gstats_label(153, ' ', 'LTDIR_CTL - L to M transposition') call gstats_label(157, ' ', 'FTINV_CTL - L to G transposition') call gstats_label(158, ' ', 'FTDIR_CTL - G to L transposition') call gstats_label(400, ' ', 'GSTATS - GSTATS itself') end subroutine gstats_labels end program ectrans_benchmark !=================================================================================================== ectrans-1.8.0/src/programs/util/0000775000175000017500000000000015174631767016762 5ustar alastairalastairectrans-1.8.0/src/programs/util/ectrans_memory.F900000664000175000017500000005332315174631767022277 0ustar alastairalastairmodule ectrans_memory use, intrinsic :: iso_c_binding, only : c_char private public :: allocator type allocator_t contains procedure, nopass :: set_pinning procedure, nopass :: set_logging procedure, nopass :: set_logging_output_unit procedure, nopass, private :: allocate_var_real32_r1 procedure, nopass, private :: allocate_var_real32_r2 procedure, nopass, private :: allocate_var_real32_r3 procedure, nopass, private :: allocate_var_real32_r4 procedure, nopass, private :: allocate_var_real64_r1 procedure, nopass, private :: allocate_var_real64_r2 procedure, nopass, private :: allocate_var_real64_r3 procedure, nopass, private :: allocate_var_real64_r4 procedure, nopass, private :: allocate_var_label_real32_r1 procedure, nopass, private :: allocate_var_label_real32_r2 procedure, nopass, private :: allocate_var_label_real32_r3 procedure, nopass, private :: allocate_var_label_real32_r4 procedure, nopass, private :: allocate_var_label_real64_r1 procedure, nopass, private :: allocate_var_label_real64_r2 procedure, nopass, private :: allocate_var_label_real64_r3 procedure, nopass, private :: allocate_var_label_real64_r4 generic :: allocate => & & allocate_var_real32_r1, & & allocate_var_real32_r2, & & allocate_var_real32_r3, & & allocate_var_real32_r4, & & allocate_var_real64_r1, & & allocate_var_real64_r2, & & allocate_var_real64_r3, & & allocate_var_real64_r4, & & allocate_var_label_real32_r1, & & allocate_var_label_real32_r2, & & allocate_var_label_real32_r3, & & allocate_var_label_real32_r4, & & allocate_var_label_real64_r1, & & allocate_var_label_real64_r2, & & allocate_var_label_real64_r3, & & allocate_var_label_real64_r4 procedure, nopass, private :: deallocate_var_real32_r1 procedure, nopass, private :: deallocate_var_real32_r2 procedure, nopass, private :: deallocate_var_real32_r3 procedure, nopass, private :: deallocate_var_real32_r4 procedure, nopass, private :: deallocate_var_real64_r1 procedure, nopass, private :: deallocate_var_real64_r2 procedure, nopass, private :: deallocate_var_real64_r3 procedure, nopass, private :: deallocate_var_real64_r4 procedure, nopass, private :: deallocate_var_label_real32_r1 procedure, nopass, private :: deallocate_var_label_real32_r2 procedure, nopass, private :: deallocate_var_label_real32_r3 procedure, nopass, private :: deallocate_var_label_real32_r4 procedure, nopass, private :: deallocate_var_label_real64_r1 procedure, nopass, private :: deallocate_var_label_real64_r2 procedure, nopass, private :: deallocate_var_label_real64_r3 procedure, nopass, private :: deallocate_var_label_real64_r4 generic :: deallocate => & & deallocate_var_real32_r1, & & deallocate_var_real32_r2, & & deallocate_var_real32_r3, & & deallocate_var_real32_r4, & & deallocate_var_real64_r1, & & deallocate_var_real64_r2, & & deallocate_var_real64_r3, & & deallocate_var_real64_r4, & & deallocate_var_label_real32_r1, & & deallocate_var_label_real32_r2, & & deallocate_var_label_real32_r3, & & deallocate_var_label_real32_r4, & & deallocate_var_label_real64_r1, & & deallocate_var_label_real64_r2, & & deallocate_var_label_real64_r3, & & deallocate_var_label_real64_r4 end type type(allocator_t) :: allocator character(kind=c_char), pointer, private :: c_label(:) => null() interface function c_allocate_var(bytes) result(ptr) bind(c, name="ectrans_memory_allocate_var") use iso_c_binding, only: c_ptr, c_size_t integer(kind=c_size_t), value :: bytes type(c_ptr) :: ptr end function subroutine c_deallocate_var(ptr, bytes) bind(c, name="ectrans_memory_deallocate_var") use iso_c_binding, only: c_ptr, c_size_t type(c_ptr), value, intent(in) :: ptr integer(c_size_t), value, intent(in) :: bytes end subroutine subroutine c_set_pinning(pinning) bind(c, name="ectrans_memory_set_pinning") use iso_c_binding, only: c_int integer(c_int), value :: pinning end subroutine subroutine c_set_label(label) bind(c, name="ectrans_memory_set_label") use iso_c_binding, only: c_ptr type(c_ptr), value :: label ! must be null-terminated ! end subroutine subroutine c_unset_label() bind(c, name="ectrans_memory_unset_label") end subroutine subroutine c_set_logging(logging) bind(c,name="ectrans_memory_set_logging") use iso_c_binding, only: c_int integer(c_int), value :: logging end subroutine subroutine c_set_logging_fortran_output_unit(output_unit) bind(c, & & name="ectrans_memory_set_logging_fortran_output_unit") use iso_c_binding, only: c_int integer(c_int), value :: output_unit end subroutine end interface contains function required_bytes(shape,real_kind) use iso_c_binding, only: c_int, c_size_t, c_float, c_double integer(c_int), intent(in) :: shape(:) integer, intent(in) :: real_kind integer(c_size_t) :: required_bytes if (real_kind == c_float) then required_bytes = product(int(shape,c_size_t)) * 4_c_size_t elseif (real_kind == c_double) then required_bytes = product(int(shape,c_size_t)) * 8_c_size_t else required_bytes = 0 endif end function subroutine set_pinning(pinning) logical, intent(in) :: pinning if (pinning) then call c_set_pinning(1) else call c_set_pinning(0) endif end subroutine subroutine set_logging(logging) logical, intent(in) :: logging if (logging) then call c_set_logging(1) else call c_set_logging(0) endif end subroutine subroutine set_logging_output_unit(output_unit) integer, intent(in) :: output_unit call c_set_logging_fortran_output_unit(output_unit) end subroutine subroutine allocate_var_real32_r1(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer real(c_float), pointer, intent(inout) :: array(:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_float)) call c_f_pointer(mem, array, shape) end subroutine subroutine allocate_var_real32_r2(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer real(c_float), pointer, intent(inout) :: array(:,:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_float)) call c_f_pointer(mem, array, shape) end subroutine subroutine allocate_var_real32_r3(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer real(c_float), pointer, intent(inout) :: array(:,:,:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_float)) call c_f_pointer(mem, array, shape) end subroutine subroutine allocate_var_real32_r4(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer real(c_float), pointer, intent(inout) :: array(:,:,:,:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_float)) call c_f_pointer(mem, array, shape) end subroutine subroutine allocate_var_real64_r1(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer real(c_double), pointer, intent(inout) :: array(:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_double)) call c_f_pointer(mem, array, shape) end subroutine subroutine allocate_var_real64_r2(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer real(c_double), pointer, intent(inout) :: array(:,:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_double)) call c_f_pointer(mem, array, shape) end subroutine subroutine allocate_var_real64_r3(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer real(c_double), pointer, intent(inout) :: array(:,:,:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_double)) call c_f_pointer(mem, array, shape) end subroutine subroutine allocate_var_real64_r4(array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer real(c_double), pointer, intent(inout) :: array(:,:,:,:) integer(c_int), intent(in) :: shape(:) type(c_ptr) :: mem mem = c_allocate_var(required_bytes(shape,c_double)) call c_f_pointer(mem, array, shape) end subroutine subroutine deallocate_var_real32_r1(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc, c_null_ptr real(c_float), pointer, intent(inout) :: array(:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_float) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine deallocate_var_real32_r2(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc, c_null_ptr real(c_float), pointer, intent(inout) :: array(:,:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_float) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1,1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine deallocate_var_real32_r3(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc, c_null_ptr real(c_float), pointer, intent(inout) :: array(:,:,:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_float) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1,1,1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine deallocate_var_real32_r4(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc, c_null_ptr real(c_float), pointer, intent(inout) :: array(:,:,:,:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_float) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1,1,1,1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine deallocate_var_real64_r1(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc, c_null_ptr real(c_double), pointer, intent(inout) :: array(:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_double) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine deallocate_var_real64_r2(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc, c_null_ptr real(c_double), pointer, intent(inout) :: array(:,:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_double) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1,1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine deallocate_var_real64_r3(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc, c_null_ptr real(c_double), pointer, intent(inout) :: array(:,:,:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_double) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1,1,1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine deallocate_var_real64_r4(array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc, c_null_ptr real(c_double), pointer, intent(inout) :: array(:,:,:,:) type(c_ptr) :: mem integer(c_size_t) :: bytes bytes = required_bytes(shape(array),c_double) mem = c_null_ptr if (bytes > 0) then mem = c_loc(array(1,1,1,1)) endif call c_deallocate_var(mem, bytes) array => null() end subroutine subroutine set_label(label) use, intrinsic :: iso_c_binding, only : c_null_char, c_loc character(len=*), intent(in) :: label integer :: j, N if (associated(c_label)) then deallocate(c_label) endif N = len_trim(label) allocate(c_label(N+1)) do j = 1, N c_label(j) = label(j:j) enddo c_label(N+1) = c_null_char call c_set_label(c_loc(c_label(1))) end subroutine subroutine unset_label() if (associated(c_label)) then deallocate(c_label) endif call c_unset_label() end subroutine subroutine allocate_var_label_real32_r1(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real32_r1(array, shape) call unset_label() end subroutine subroutine allocate_var_label_real32_r2(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:,:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real32_r2(array, shape) call unset_label() end subroutine subroutine allocate_var_label_real32_r3(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:,:,:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real32_r3(array, shape) call unset_label() end subroutine subroutine allocate_var_label_real32_r4(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:,:,:,:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real32_r4(array, shape) call unset_label() end subroutine subroutine allocate_var_label_real64_r1(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real64_r1(array, shape) call unset_label() end subroutine subroutine allocate_var_label_real64_r2(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:,:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real64_r2(array, shape) call unset_label() end subroutine subroutine allocate_var_label_real64_r3(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:,:,:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real64_r3(array, shape) call unset_label() end subroutine subroutine allocate_var_label_real64_r4(label, array, shape) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_int, c_f_pointer character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:,:,:,:) integer(c_int), intent(in) :: shape(:) call set_label(label) call allocate_var_real64_r4(array, shape) call unset_label() end subroutine subroutine deallocate_var_label_real32_r1(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:) call set_label(label) call deallocate_var_real32_r1(array) call unset_label() end subroutine subroutine deallocate_var_label_real32_r2(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:,:) call set_label(label) call deallocate_var_real32_r2(array) call unset_label() end subroutine subroutine deallocate_var_label_real32_r3(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:,:,:) call set_label(label) call deallocate_var_real32_r3(array) call unset_label() end subroutine subroutine deallocate_var_label_real32_r4(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_float, c_loc character(len=*), intent(in) :: label real(c_float), pointer, intent(inout) :: array(:,:,:,:) call set_label(label) call deallocate_var_real32_r4(array) call unset_label() end subroutine subroutine deallocate_var_label_real64_r1(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:) call set_label(label) call deallocate_var_real64_r1(array) call unset_label() end subroutine subroutine deallocate_var_label_real64_r2(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:,:) call set_label(label) call deallocate_var_real64_r2(array) call unset_label() end subroutine subroutine deallocate_var_label_real64_r3(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:,:,:) call set_label(label) call deallocate_var_real64_r3(array) call unset_label() end subroutine subroutine deallocate_var_label_real64_r4(label, array) use, intrinsic :: iso_c_binding, only : c_size_t, c_ptr, c_double, c_loc character(len=*), intent(in) :: label real(c_double), pointer, intent(inout) :: array(:,:,:,:) call set_label(label) call deallocate_var_real64_r4(array) call unset_label() end subroutine subroutine c_write_to_fortran_unit(unit,msg_cptr) bind(c, name="ectrans_memory_write_to_fortran_unit") use, intrinsic :: iso_c_binding, only: c_int32_t, c_ptr, c_char, c_associated integer(c_int32_t), value, intent(in) :: unit type(c_ptr), value, intent(in) :: msg_cptr character(kind=c_char,len=:), allocatable :: msg if( c_associated(msg_cptr) ) then call copy_c_ptr_to_string( msg_cptr, msg ) write(unit,'(A)', advance='no') msg endif contains subroutine copy_c_str_to_string(s,string) use, intrinsic :: iso_c_binding character(kind=c_char,len=1), intent(in) :: s(:) character(len=:), allocatable :: string integer :: i, nchars do i = 1, size(s) if (s(i) == c_null_char) exit enddo nchars = i - 1 ! Exclude null character from Fortran string allocate( character(len=(nchars),kind=c_char) :: string ) do i=1,nchars string(i:i) = s(i) enddo end subroutine subroutine copy_c_ptr_to_string(cptr,string) use, intrinsic :: iso_c_binding type(c_ptr), intent(in) :: cptr character(kind=c_char,len=:), allocatable :: string character(kind=c_char), dimension(:), pointer :: s integer(c_int), parameter :: MAX_STR_LEN = 2550 call c_f_pointer ( cptr , s, (/MAX_STR_LEN/) ) call copy_c_str_to_string( s, string ) end subroutine end subroutine end module ectrans-1.8.0/src/programs/util/ectrans_memory.c0000664000175000017500000001070515174631767022160 0ustar alastairalastair#include #include #include #include #define PREFIX ectrans_memory_ #define CONCAT_(A, B) A##B #define CONCAT(A, B) CONCAT_(A, B) #define PREFIXED(symbol) CONCAT(PREFIX, symbol) #define allocate_var PREFIXED(allocate_var) #define deallocate_var PREFIXED(deallocate_var) #define set_label PREFIXED(set_label) #define unset_label PREFIXED(unset_label) #define set_logging PREFIXED(set_logging) #define set_logging_fortran_output_unit PREFIXED(set_logging_fortran_output_unit) #define write_to_fortran_unit PREFIXED(write_to_fortran_unit) #define set_pinning PREFIXED(set_pinning) // ---------------------------------------------------------------------------------------- // API // Allocate memory of given bytes void* allocate_var(size_t bytes); // Deallocate memory of given bytes // The bytes argument is not strictly needed but may be useful for logging void deallocate_var(void* ptr, size_t bytes); // Set/Unset a label that can be used for logging during the above calls void set_label(const char* label); void unset_label(); // Set logging. accepted values: 1,0 (true, false) void set_logging(int); // Set Fortran output unit void set_logging_fortran_unit(int); // Set pinning. accepted values: 1,0 (true, false) // Pinning is off by default void set_pinning(int); // ---------------------------------------------------------------------------------------- // Implementation #if defined(CUDA) #include #define hicHostRegisterMapped cudaHostRegisterMapped #define hicHostRegister(ptr, bytes, flag) cudaHostRegister(ptr, bytes, flag); #define hicHostUnregister(ptr) cudaHostUnregister(ptr); #define HIC #elif defined(HIP) #include #define hicHostRegisterMapped hipHostRegisterMapped #define hicHostRegister(ptr, bytes, flag) hipHostRegister(ptr, bytes, flag); #define hicHostUnregister(ptr) hipHostUnregister(ptr); #define HIC #else // Mockup version of pinning for host-only #define hicHostRegisterMapped 0 static int hicHostRegister(void* ptr, size_t bytes, int flag) { return 0; } static int hicHostUnregister(void* ptr) { return 0; } #endif static const char* label_ = NULL; static int logging_ = 0; static int logging_fortran_output_unit_ = 0; static int pinning_ = 0; void write_to_fortran_unit( int unit, const char* msg ); static void fortran_printf(const char *format, ...) { char buffer[256]; va_list args; va_start (args, format); vsnprintf (buffer,256,format, args); write_to_fortran_unit(logging_fortran_output_unit_, buffer); va_end (args); } static void default_err_callback(const char* err_msg) { fortran_printf(0, "%s\n", err_msg); } typedef void (*err_callback_t)(const char* err_msg); static err_callback_t err_callback = default_err_callback; // err_callback could be runtime-configured to something that calls e.g. abor1 void set_label(const char* label) { label_ = label; } void unset_label() { label_ = NULL; } void set_pinning(int pinning) { if (logging_) { fortran_printf("Set pinning to %d\n", pinning); } pinning_ = pinning; } void set_logging(int logging) { logging_ = logging; } void set_logging_fortran_output_unit(int output_unit) { logging_fortran_output_unit_ = output_unit; } static void* allocate_pinned(size_t bytes) { void* ptr = malloc(bytes); if (bytes && pinning_) { int err = hicHostRegister(ptr, bytes, hicHostRegisterMapped); if (err) { err_callback("Error pinning memory"); } } return ptr; } static void deallocate_pinned(void* ptr, size_t bytes) { if (ptr && pinning_) { int err = hicHostUnregister(ptr); if (err) { err_callback("Error unpinning memory"); } free(ptr); } } void* allocate_var(size_t bytes) { if (logging_) { if (label_) { fortran_printf("Allocating variable %s with %zu %s bytes\n", label_, bytes, pinning_ ? "pinned" : ""); } else { fortran_printf("Allocating variable with %zu %s bytes\n", bytes, pinning_ ? "pinned" : ""); } } return allocate_pinned(bytes); } void deallocate_var(void* ptr, size_t bytes) { if (logging_) { if (label_) { fortran_printf("Deallocating variable %s with %zu %s bytes\n", label_, bytes, pinning_ ? "pinned" : ""); } else { fortran_printf("Deallocating variable with %zu %s bytes\n", bytes, pinning_ ? "pinned" : ""); } } deallocate_pinned(ptr, bytes); } ectrans-1.8.0/src/programs/ectrans-benchmark-ifs.F900000664000175000017500000014722515174631767022446 0ustar alastairalastair! (C) Copyright 2014- ECMWF. ! ! 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. ! program transform_test ! ! Spectral transform test ! ! This test performs spectral to real and real to spectral transforms repeated in ! timed loop. ! ! 1) One "surface" field is always transformed: ! zspsc2(1,1:nspec2) <-> zgmvs(1:nproma,1:1,1:ngbplk) ! ! 2) A Multiple "3d" fields are transformed and can be disabled with "--nfld 0" ! ! zspsc3a(1:nlev,1:nspec2,1:nfld) <-> zgp3a(1:nproma,1:nlev,1:nfld,1:ngpblk) ! ! 3) Optionally a "3d" vorticity/divergence field is transformed to uv (wind) and ! can be enabled with "--vordiv" ! ! zspvor(1:nlev,1:nspec2) / zspdiv(1:nlev,1:nspec2) <-> zgpuv(1:nproma,1:nlev,1:2,1:ngpblk) ! ! 4) Optionally scalar derivatives can be computed for the fields described in 1) and 2) ! This must be enabled with "--scders" ! ! 5) Optionally uv East-West derivate can be computed from vorticity/divergence. ! This must be enabled with "--vordiv --uvders" ! ! ! Authors : George Mozdzynski ! Willem Deconinck ! Ioan Hadade ! Sam Hatfield ! use parkind1, only: jpim, jprb, jprd use oml_mod ,only : oml_max_threads use mpl_module use yomgstats, only: jpmaxstat use yomhook, only : dr_hook_init implicit none ! Number of points in top/bottom latitudes integer(kind=jpim), parameter :: min_octa_points = 20 integer(kind=jpim) :: istack, getstackusage real(kind=jprb), dimension(1) :: zmaxerr(5), zerr(5) real(kind=jprb) :: zmaxerrg ! Output unit numbers integer(kind=jpim), parameter :: nerr = 0 ! Unit number for STDERR integer(kind=jpim), parameter :: nout = 6 ! Unit number for STDOUT integer(kind=jpim), parameter :: noutdump = 7 ! Unit number for field output ! Default parameters integer(kind=jpim) :: nsmax = 79 ! Spectral truncation integer(kind=jpim) :: iters = 10 ! Number of iterations for transform test integer(kind=jpim) :: nfld = 1 ! Number of scalar fields integer(kind=jpim) :: nlev = 1 ! Number of vertical levels integer(kind=jpim) :: nflevg integer(kind=jpim) :: ndgl ! Number of latitudes integer(kind=jpim) :: nspec2 integer(kind=jpim) :: ngptot integer(kind=jpim) :: ngptotg integer(kind=jpim) :: ifld integer(kind=jpim) :: jroc integer(kind=jpim) :: jb integer(kind=jpim) :: nspec2g integer(kind=jpim) :: i integer(kind=jpim) :: ja integer(kind=jpim) :: ib integer(kind=jpim) :: jprtrv integer(kind=jpim), allocatable :: nloen(:), nprcids(:) integer(kind=jpim) :: myproc, jj, jf, ilf integer :: jstep real(kind=jprd) :: ztinit, ztloop, timef, ztstepmax, ztstepmin, ztstepavg, ztstepmed real(kind=jprd) :: ztstepmax1, ztstepmin1, ztstepavg1, ztstepmed1 real(kind=jprd) :: ztstepmax2, ztstepmin2, ztstepavg2, ztstepmed2 real(kind=jprd), allocatable :: ztstep(:), ztstep1(:), ztstep2(:) real(kind=jprb), allocatable :: znormsp(:), znormsp1(:), znormdiv(:), znormdiv1(:) real(kind=jprb), allocatable :: znormvor(:), znormvor1(:), znormt(:), znormt1(:) real(kind=jprd) :: zaveave(0:jpmaxstat) ! Grid-point space data structures real(kind=jprb), allocatable, target :: zgmv (:,:,:,:) ! Multilevel fields at t and t-dt real(kind=jprb), allocatable, target :: zgmvs (:,:,:) ! Single level fields at t and t-dt real(kind=jprb), pointer :: zgp3a (:,:,:,:) ! Multilevel fields at t and t-dt real(kind=jprb), pointer :: zgpuv (:,:,:,:) ! Multilevel fields at t and t-dt real(kind=jprb), pointer :: zgp2 (:,:,:) ! Single level fields at t and t-dt ! Spectral space data structures real(kind=jprb), allocatable, target :: sp3d(:,:,:) real(kind=jprb), pointer :: zspvor(:,:) => null() real(kind=jprb), pointer :: zspdiv(:,:) => null() real(kind=jprb), pointer :: zspsc3a(:,:,:) => null() real(kind=jprb), allocatable :: zspsc2(:,:) real(kind=jprb), allocatable :: zave(:),zmin(:),zmax(:),zreel(:,:,:) logical :: lstack = .false. ! Output stack info logical :: luserpnm = .false. logical :: lkeeprpnm = .false. logical :: luseflt = .false. ! Use fast legendre transforms logical :: ltrace_stats = .false. logical :: lstats_omp = .false. logical :: lstats_comms = .false. logical :: lstats_mpl = .false. logical :: lstats = .true. ! gstats statistics logical :: lbarrier_stats = .false. logical :: lbarrier_stats2 = .false. logical :: ldetailed_stats = .false. logical :: lstats_alloc = .false. logical :: lsyncstats = .false. logical :: lstatscpu = .false. logical :: lstats_mem = .false. logical :: lxml_stats = .false. logical :: lfftw = .true. ! Use FFTW for Fourier transforms logical :: lvordiv = .false. logical :: lscders = .false. logical :: luvders = .false. logical :: lprint_norms = .false. ! Calculate and print spectral norms logical :: lmeminfo = .false. ! Show information from FIAT routine ec_meminfo at the end logical :: lgpnorms = .false. ! print gpnorms integer(kind=jpim) :: nstats_mem = 0 integer(kind=jpim) :: ntrace_stats = 0 integer(kind=jpim) :: nprnt_stats = 1 ! The multiplier of the machine epsilon used as a tolerance for correctness checking ! ncheck = 0 (the default) means that correctness checking is disabled integer(kind=jpim) :: ncheck = 0 logical :: lmpoff = .false. ! Message passing switch ! Verbosity level (0 or 1) integer :: verbosity = 0 real(kind=jprb) :: zra = 6371229._jprb integer(kind=jpim) :: nmax_resol = 37 ! Max number of resolutions integer(kind=jpim) :: npromatr = 0 ! nproma for trans lib integer(kind=jpim) :: ncombflen = 1800000 ! Size of comm buffer integer(kind=jpim) :: nproc ! Number of procs integer(kind=jpim) :: nthread integer(kind=jpim) :: nprgpns ! Grid-point decomp integer(kind=jpim) :: nprgpew ! Grid-point decomp integer(kind=jpim) :: nprtrv = 0 ! Spectral decomp integer(kind=jpim) :: nprtrw = 0 ! Spectral decomp integer(kind=jpim) :: nspecresmin = 80 ! Minimum spectral resolution, for controlling nprtrw integer(kind=jpim) :: mysetv integer(kind=jpim) :: mysetw integer(kind=jpim) :: mp_type = 2 ! Message passing type integer(kind=jpim) :: mbx_size = 150000000 ! Mailbox size integer(kind=jpim), allocatable :: numll(:), ivset(:) integer(kind=jpim) :: ivsetsc(1) integer(kind=jpim) :: nflevl ! sumpini integer(kind=jpim) :: isqr logical :: lsync_trans = .true. ! Activate barrier sync logical :: leq_regions = .true. ! Eq regions flag integer(kind=jpim) :: nproma = 0 integer(kind=jpim) :: ngpblks ! locals integer(kind=jpim) :: iprtrv integer(kind=jpim) :: iprtrw integer(kind=jpim) :: iprused, ilevpp, irest, ilev, jlev, iprev integer(kind=jpim) :: ndimgmv = 0 ! Third dim. of gmv "(nproma,nflevg,ndimgmv,ngpblks)" integer(kind=jpim) :: ndimgmvs = 0 ! Second dim. gmvs "(nproma,ndimgmvs,ngpblks)" integer(kind=jpim) :: jbegin_uv = 0 integer(kind=jpim) :: jend_uv = 0 integer(kind=jpim) :: jbegin_sc = 0 integer(kind=jpim) :: jend_sc = 0 integer(kind=jpim) :: jbegin_scder_NS = 0 integer(kind=jpim) :: jend_scder_NS = 0 integer(kind=jpim) :: jbegin_scder_EW = 0 integer(kind=jpim) :: jend_scder_EW = 0 integer(kind=jpim) :: jbegin_uder_EW = 0 integer(kind=jpim) :: jend_uder_EW = 0 integer(kind=jpim) :: jbegin_vder_EW = 0 integer(kind=jpim) :: jend_vder_EW = 0 logical :: ldump_values = .false. integer, external :: ec_mpirank logical :: luse_mpi = .true. character(len=16) :: cgrid = '' !=================================================================================================== #include "setup_trans0.h" #include "setup_trans.h" #include "inv_trans.h" #include "dir_trans.h" #include "trans_inq.h" #include "specnorm.h" #include "gpnorm_trans.h" #include "abor1.intfb.h" #include "gstats_setup.intfb.h" #include "ec_meminfo.intfb.h" !=================================================================================================== luse_mpi = detect_mpirun() ! Setup call get_command_line_arguments(nsmax, cgrid, iters, nfld, nlev, lvordiv, lscders, luvders, lgpnorms, & & luseflt, nproma, verbosity, ldump_values, lprint_norms, lmeminfo, nprtrv, nprtrw, ncheck) if (cgrid == '') cgrid = cubic_octahedral_gaussian_grid(nsmax) call parse_grid(cgrid, ndgl, nloen) nflevg = nlev !=================================================================================================== if (luse_mpi) then call mpl_init(ldinfo=(verbosity>=1)) nproc = mpl_nproc() myproc = mpl_myrank() else nproc = 1 myproc = 1 mpl_comm = -1 endif nthread = oml_max_threads() call dr_hook_init() !=================================================================================================== if( lstats ) call gstats(0,0) ztinit = timef() ! only output to stdout on pe 1 if (nproc > 1) then if (myproc /= 1) then open(unit=nout, file='/dev/null') endif endif if (ldetailed_stats) then lstats_omp = .true. lstats_comms = .true. lstats_mpl = .true. lstatscpu = .true. nprnt_stats = nproc ! lstats_mem = .true. ! lstats_alloc = .true. endif !=================================================================================================== allocate(nprcids(nproc)) do jj = 1, nproc nprcids(jj) = jj enddo if (nproc <= 1) then lmpoff = .true. endif ! Compute nprgpns and nprgpew ! This version selects most square-like distribution ! These will change if leq_regions=.true. if (nproc == 0) nproc = 1 isqr = int(sqrt(real(nproc,jprb))) do ja = isqr, nproc ib = nproc/ja if (ja*ib == nproc) then nprgpns = max(ja,ib) nprgpew = min(ja,ib) exit endif enddo ! From sumpini, although this should be specified in namelist if (nspecresmin == 0) nspecresmin = nproc ! Compute nprtrv and nprtrw if not provided on the command line if (nprtrv > 0 .or. nprtrw > 0) then if (nprtrv == 0) nprtrv = nproc/nprtrw if (nprtrw == 0) nprtrw = nproc/nprtrv if (nprtrw*nprtrv /= nproc) call abor1('transform_test:nprtrw*nprtrv /= nproc') if (nprtrw > nspecresmin) call abor1('transform_test:nprtrw > nspecresmin') else do jprtrv = 4, nproc nprtrv = jprtrv nprtrw = nproc/nprtrv if (nprtrv*nprtrw /= nproc) cycle if (nprtrv > nprtrw) exit if (nprtrw > nspecresmin) cycle if (nprtrw <= nspecresmin/(2*oml_max_threads())) exit enddo ! Go for approx square partition for backup if (nprtrv*nprtrw /= nproc .or. nprtrw > nspecresmin .or. nprtrv > nprtrw) then isqr = int(sqrt(real(nproc,jprb))) do ja = isqr, nproc ib = nproc/ja if (ja*ib == nproc) then nprtrw = max(ja, ib) nprtrv = min(ja, ib) if (nprtrw > nspecresmin ) then call abor1('transform_test:nprtrw (approx square value) > nspecresmin') endif exit endif enddo endif endif ! Create communicators for mpi groups if (.not.lmpoff) then call mpl_groups_create(nprtrw, nprtrv) endif if (lmpoff) then mysetw = (myproc - 1)/nprtrv + 1 mysetv = mod(myproc - 1, nprtrv) + 1 else call mpl_cart_coords(myproc, mysetw, mysetv) ! Just checking for now... iprtrv = mod(myproc - 1, nprtrv) + 1 iprtrw = (myproc - 1)/nprtrv + 1 if (iprtrv /= mysetv .or. iprtrw /= mysetw) then call abor1('transform_test:inconsistency when computing mysetw and mysetv') endif endif if (.not. lmpoff) then call mpl_buffer_method(kmp_type=mp_type, kmbx_size=mbx_size, kprocids=nprcids, ldinfo=(verbosity>=1)) endif ! Determine number of local levels for fourier and legendre calculations ! based on the values of nflevg and nprtrv allocate(numll(nprtrv+1)) ! Calculate remainder iprused = min(nflevg+1, nprtrv) ilevpp = nflevg/nprtrv irest = nflevg -ilevpp*nprtrv do jroc = 1, nprtrv if (jroc <= irest) then numll(jroc) = ilevpp+1 else numll(jroc) = ilevpp endif enddo numll(iprused+1:nprtrv+1) = 0 nflevl = numll(mysetv) ivsetsc(1) = iprused ifld = 0 !=================================================================================================== ! Setup gstats !=================================================================================================== if (lstats) then call gstats_setup(nproc, myproc, nprcids, & & lstats, lstatscpu, lsyncstats, ldetailed_stats, lbarrier_stats, lbarrier_stats2, & & lstats_omp, lstats_comms, lstats_mem, nstats_mem, lstats_alloc, & & ltrace_stats, ntrace_stats, nprnt_stats, lxml_stats) call gstats_psut ! Assign labels to GSTATS regions call gstats_labels endif !=================================================================================================== ! Call ecTrans setup routines !=================================================================================================== if (verbosity >= 1) write(nout,'(a)')'======= Setup ecTrans =======' call gstats(1, 0) call setup_trans0(kout=nout, kerr=nerr, kprintlev=merge(2, 0, verbosity == 1), & & kmax_resol=nmax_resol, kpromatr=npromatr, kprgpns=nprgpns, kprgpew=nprgpew, & & kprtrw=nprtrw, kcombflen=ncombflen, ldsync_trans=lsync_trans, & & ldeq_regions=leq_regions, prad=zra, ldalloperm=.true., ldmpoff=.not.luse_mpi) call gstats(1, 1) call gstats(2, 0) call setup_trans(ksmax=nsmax, kdgl=ndgl, kloen=nloen, ldsplit=.true., & & ldusefftw=lfftw, lduserpnm=luserpnm, ldkeeprpnm=lkeeprpnm, & & lduseflt=luseflt) call gstats(2, 1) call trans_inq(kspec2=nspec2, kspec2g=nspec2g, kgptot=ngptot, kgptotg=ngptotg) if (nproma == 0) then ! no blocking (default when not specified) nproma = ngptot endif ! Calculate number of NPROMA blocks ngpblks = (ngptot - 1)/nproma+1 !=================================================================================================== ! Print information before starting !=================================================================================================== ! Print configuration details if (verbosity >= 0) then write(nout,'(" ")') write(nout,'(a)')'======= Start of runtime parameters =======' write(nout,'(" ")') write(nout,'("nsmax ",i0)') nsmax write(nout,'("grid ",a)') trim(cgrid) write(nout,'("ndgl ",i0)') ndgl write(nout,'("nproc ",i0)') nproc write(nout,'("nthread ",i0)') nthread write(nout,'("nprgpns ",i0)') nprgpns write(nout,'("nprgpew ",i0)') nprgpew write(nout,'("nprtrw ",i0)') nprtrw write(nout,'("nprtrv ",i0)') nprtrv write(nout,'("ngptot ",i0)') ngptot write(nout,'("ngptotg ",i0)') ngptotg write(nout,'("nfld ",i0)') nfld write(nout,'("nlev ",i0)') nlev write(nout,'("nproma ",i0)') nproma write(nout,'("ngpblks ",i0)') ngpblks write(nout,'("nspec2 ",i0)') nspec2 write(nout,'("nspec2g ",i0)') nspec2g write(nout,'("luseflt ",l)') luseflt write(nout,'("lvordiv ",l)') lvordiv write(nout,'("lscders ",l)') lscders write(nout,'("luvders ",l)') luvders write(nout,'("lgpnorms ",l)') lgpnorms write(nout,'(" ")') write(nout,'(a)') '======= End of runtime parameters =======' write(nout,'(" ")') end if !=================================================================================================== ! Allocate and Initialize spectral arrays !=================================================================================================== ! Allocate spectral arrays ! Try to mimick IFS layout as much as possible nullify(zspvor) nullify(zspdiv) nullify(zspsc3a) allocate(sp3d(nflevl,nspec2,2+nfld)) allocate(zspsc2(1,nspec2)) call initialize_spectral_arrays(nsmax, zspsc2, sp3d) ! Point convenience variables to storage variable sp3d zspvor => sp3d(:,:,1) zspdiv => sp3d(:,:,2) zspsc3a => sp3d(:,:,3:3+(nfld-1)) !=================================================================================================== ! Allocate gridpoint arrays !=================================================================================================== allocate(ivset(nflevg)) ! Compute spectral distribution ilev = 0 do jb = 1, nprtrv do jlev=1, numll(jb) ilev = ilev + 1 ivset(ilev) = jb enddo enddo ! Allocate grid-point arrays if (lvordiv) then jbegin_uv = 1 jend_uv = 2 endif if (luvders) then jbegin_uder_EW = jend_uv + 1 jend_uder_EW = jbegin_uder_EW + 1 jbegin_vder_EW = jend_uder_EW + 1 jend_vder_EW = jbegin_vder_EW + 1 else jbegin_uder_EW = jend_uv jend_uder_EW = jend_uv jbegin_vder_EW = jend_uv jend_vder_EW = jend_uv endif jbegin_sc = jend_vder_EW + 1 jend_sc = jend_vder_EW + nfld if (lscders) then ndimgmvs = 3 jbegin_scder_NS = jend_sc + 1 jend_scder_NS = jend_sc + nfld jbegin_scder_EW = jend_scder_NS + 1 jend_scder_EW = jend_scder_NS + nfld else ndimgmvs = 1 jbegin_scder_NS = jend_sc jend_scder_NS = jend_sc jbegin_scder_EW = jend_sc jend_scder_EW = jend_sc endif ndimgmv = jend_scder_EW allocate(zgmv(nproma,nflevg,ndimgmv,ngpblks)) allocate(zgmvs(nproma,ndimgmvs,ngpblks)) zgpuv => zgmv(:,:,1:jend_vder_EW,:) zgp3a => zgmv(:,:,jbegin_sc:jend_scder_EW,:) zgp2 => zgmvs(:,:,:) !=================================================================================================== ! Allocate norm arrays !=================================================================================================== if (lprint_norms .or. ncheck > 0) then allocate(znormsp(1)) allocate(znormsp1(1)) allocate(znormvor(nflevg)) allocate(znormvor1(nflevg)) allocate(znormdiv(nflevg)) allocate(znormdiv1(nflevg)) allocate(znormt(nflevg)) allocate(znormt1(nflevg)) call specnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor1, kvset=ivset(1:nflevg)) call specnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv1, kvset=ivset(1:nflevg)) call specnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt1, kvset=ivset(1:nflevg)) call specnorm(pspec=zspsc2(1:1,:), pnorm=znormsp1, kvset=ivsetsc) if (verbosity >= 1) then do ifld = 1, nflevg write(nout,'("norm zspvor( ",i4,",:) = ",f20.15)') ifld, znormvor1(ifld) enddo do ifld = 1, nflevg write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15)') ifld, znormdiv1(ifld) enddo do ifld = 1, nflevg write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15)') ifld, znormt1(ifld) enddo do ifld = 1, 1 write(nout,'("norm zspsc2( ",i4,",:) = ",f20.15)') ifld, znormsp1(ifld) enddo endif endif !=================================================================================================== ! Setup timers !=================================================================================================== ztinit = (timef() - ztinit)/1000.0_jprd if (verbosity >= 0) then write(nout,'(" ")') write(nout,'(a,i6,a,f9.2,a)') "transform_test initialisation, on",nproc,& & " tasks, took",ztinit," sec" write(nout,'(" ")') endif if (iters <= 0) call abor1('transform_test:iters <= 0') allocate(ztstep(iters)) allocate(ztstep1(iters)) allocate(ztstep2(iters)) ztstepavg = 0._jprd ztstepmax = 0._jprd ztstepmin = 9999999999999999._jprd ztstepavg1 = 0._jprd ztstepmax1 = 0._jprd ztstepmin1 = 9999999999999999._jprd ztstepavg2 = 0._jprd ztstepmax2 = 0._jprd ztstepmin2 = 9999999999999999._jprd write(nout,'(a)') '======= Start of spectral transforms =======' write(nout,'(" ")') ztloop = timef() !=================================================================================================== ! Do spectral transform loop !=================================================================================================== do jstep = 1, iters call gstats(3,0) ztstep(jstep) = timef() !================================================================================================= ! Do inverse transform !================================================================================================= ztstep1(jstep) = timef() call gstats(4,0) if (lvordiv) then ! test different paradigms with small trans first, single field + derivatives, emulating sporog trans in IFS write(nout,*) 'Test sporog like single transform ...' call flush(nout) ! special case when single transform, reset later iprev = ivsetsc(1) ivsetsc(1) = nprtrv ilf = 0 if(nprtrv == mysetv) then ilf = 1 endif allocate(zreel(nproma,3,ngpblks)) zreel(:,:,:)=0._jprb call inv_trans(kresol=1, kproma=nproma, & & pspscalar=zspsc2(1:ilf,:), & ! spectral scalar & ldscders=.true., & ! scalar derivatives & kvsetsc=ivsetsc, & & pgp=zreel) if( lgpnorms ) then ! reset prev value ivsetsc(1) = iprev write(nout,*) 'statistics gpnorm_trans ...' call flush(nout) ifld=3 allocate(zave(ifld)) allocate(zmin(ifld)) allocate(zmax(ifld)) call gpnorm_trans(zreel,ifld,nproma,zave,zmin,zmax,.false.,kresol=1) do jf=1,ifld write(nout,*) '1st Statistics field= ',jf,' : ave,min,max ',zave(jf),zmin(jf),zmax(jf) call flush(nout) enddo deallocate(zave) deallocate(zmin) deallocate(zmax) endif deallocate(zreel) write(nout,*) 'standard time-step ...' call flush(nout) zgpuv(:,:,:,:) = 0._JPRB ! full time step call inv_trans(kresol=1, kproma=nproma, & & pspsc2=zspsc2, & ! spectral surface pressure & pspvor=zspvor, & ! spectral vorticity & pspdiv=zspdiv, & ! spectral divergence & pspsc3a=zspsc3a, & ! spectral scalars & ldscders=lscders, & & ldvorgp=.false., & ! no gridpoint vorticity & lddivgp=.false., & ! no gridpoint divergence & lduvder=luvders, & & kvsetuv=ivset, & & kvsetsc2=ivsetsc, & & kvsetsc3a=ivset, & & pgp2=zgp2, & & pgpuv=zgpuv, & & pgp3a=zgp3a) if( lgpnorms ) then write(nout,*) 'statistics gpnorm_trans all levels ...' call flush(nout) allocate(zave(nflevg)) allocate(zmin(nflevg)) allocate(zmax(nflevg)) ! vorticity only, all levels ifld=1 call gpnorm_trans(zgpuv(:,1:nflevg,ifld,:),nflevg,nproma,zave,zmin,zmax,.false.,1) do jf=1,nflevg write(nout,*) 'Statistics vorticity level= ',jf,' : ave,min,max ',zave(jf),zmin(jf),zmax(jf) call flush(nout) enddo call gpnorm_trans(zgp3a(:,1:nflevg,ifld,:),nflevg,nproma,zave,zmin,zmax,.false.,1) do jf=1,nflevg write(nout,*) 'Statistics scalar level= ',jf,' : ave,min,max ',zave(jf),zmin(jf),zmax(jf) call flush(nout) enddo call gpnorm_trans(zgp3a(:,1:nflevg,ifld+nfld,:),nflevg,nproma,zave,zmin,zmax,.false.,1) do jf=1,nflevg write(nout,*) 'Statistics scalar x-der level= ',jf,' : ave,min,max ',zave(jf),zmin(jf),zmax(jf) call flush(nout) enddo call gpnorm_trans(zgp3a(:,1:nflevg,ifld+2*nfld,:),nflevg,nproma,zave,zmin,zmax,.false.,1) do jf=1,nflevg write(nout,*) 'Statistics scalar y-der level= ',jf,' : ave,min,max ',zave(jf),zmin(jf),zmax(jf) call flush(nout) enddo deallocate(zave) deallocate(zmin) deallocate(zmax) endif ! test different paradigms with small trans first, single field + derivatives, emulating sporog trans in IFS write(nout,*) 'Test sporog like single transform ...' call flush(nout) ! special case when single transform, reset later iprev = ivsetsc(1) ivsetsc(1) = nprtrv ilf = 0 if(nprtrv == mysetv) then ilf = 1 endif allocate(zreel(nproma,3,ngpblks)) zreel(:,:,:)=0._jprb call inv_trans(kresol=1, kproma=nproma, & & pspscalar=zspsc2(1:ilf,:), & ! spectral scalar & ldscders=.true., & ! scalar derivatives & kvsetsc=ivsetsc, & & pgp=zreel) if( lgpnorms ) then ! reset prev value ivsetsc(1) = iprev write(nout,*) 'statistics gpnorm_trans ...' call flush(nout) ifld=3 allocate(zave(ifld)) allocate(zmin(ifld)) allocate(zmax(ifld)) call gpnorm_trans(zreel,ifld,nproma,zave,zmin,zmax,.false.,kresol=1) do jf=1,ifld write(nout,*) '2nd Statistics field= ',jf,' : ave,min,max ',zave(jf),zmin(jf),zmax(jf) call flush(nout) enddo deallocate(zave) deallocate(zmin) deallocate(zmax) endif deallocate(zreel) else call inv_trans(kresol=1, kproma=nproma, & & pspsc2=zspsc2, & ! spectral surface pressure & pspsc3a=zspsc3a, & ! spectral scalars & ldscders=lscders, & ! scalar derivatives & kvsetsc2=ivsetsc, & & kvsetsc3a=ivset, & & pgp2=zgp2, & & pgp3a=zgp3a) endif call gstats(4,1) ztstep1(jstep) = (timef() - ztstep1(jstep))/1000.0_jprd !================================================================================================= ! While in grid point space, dump the values to disk, for debugging only !================================================================================================= if (ldump_values) then ! dump a field to a binary file call dump_gridpoint_field(jstep, myproc, nproma, ngpblks, zgp2(:,1,:), 'S', noutdump) call dump_gridpoint_field(jstep, myproc, nproma, ngpblks, zgpuv(:,nflevg,1,:), 'U', noutdump) call dump_gridpoint_field(jstep, myproc, nproma, ngpblks, zgpuv(:,nflevg,2,:), 'V', noutdump) call dump_gridpoint_field(jstep, myproc, nproma, ngpblks, zgp3a(:,nflevg,1,:), 'T', noutdump) endif !================================================================================================= ! Do direct transform !================================================================================================= ztstep2(jstep) = timef() call gstats(5,0) if (lvordiv) then call dir_trans(kresol=1, kproma=nproma, & & pgp2=zgmvs(:,1:1,:), & & pgpuv=zgpuv(:,:,1:2,:), & & pgp3a=zgp3a(:,:,1:nfld,:), & & pspvor=zspvor, & & pspdiv=zspdiv, & & pspsc2=zspsc2, & & pspsc3a=zspsc3a, & & kvsetuv=ivset, & & kvsetsc2=ivsetsc, & & kvsetsc3a=ivset) else call dir_trans(kresol=1, kproma=nproma, & & pgp=zgp3a(:,1,1:nfld,:), & & pspscalar=zspsc3a(1:1,1:nfld,1), & ! spectral scalar & kvsetsc=ivset) ! call dir_trans(kresol=1, kproma=nproma, & ! & pgp2=zgmvs(:,1:1,:), & ! & pgp3a=zgp3a(:,:,1:nfld,:), & ! & pspsc2=zspsc2, & ! & pspsc3a=zspsc3a, & ! & kvsetsc2=ivsetsc, & ! & kvsetsc3a=ivset) endif call gstats(5,1) ztstep2(jstep) = (timef() - ztstep2(jstep))/1000.0_jprd !================================================================================================= ! Calculate timings !================================================================================================= ztstep(jstep) = (timef() - ztstep(jstep))/1000.0_jprd ztstepavg = ztstepavg + ztstep(jstep) ztstepmin = min(ztstep(jstep), ztstepmin) ztstepmax = max(ztstep(jstep), ztstepmax) ztstepavg1 = ztstepavg1 + ztstep1(jstep) ztstepmin1 = min(ztstep1(jstep), ztstepmin1) ztstepmax1 = max(ztstep1(jstep), ztstepmax1) ztstepavg2 = ztstepavg2 + ztstep2(jstep) ztstepmin2 = min(ztstep2(jstep), ztstepmin2) ztstepmax2 = max(ztstep2(jstep), ztstepmax2) !================================================================================================= ! Print norms !================================================================================================= if (lprint_norms) then call gstats(6,0) call specnorm(pspec=zspsc2(1:1,:), pnorm=znormsp, kvset=ivsetsc(1:1)) call specnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset(1:nflevg)) call specnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset(1:nflevg)) call specnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt, kvset=ivset(1:nflevg)) ! Surface pressure zmaxerr(:) = -999.0 do ifld = 1, 1 zerr(1) = abs(znormsp1(ifld)/znormsp(ifld) - 1.0_jprb) zmaxerr(1) = max(zmaxerr(1), zerr(1)) enddo ! Divergence do ifld = 1, nflevg zerr(2) = abs(znormdiv1(ifld)/znormdiv(ifld) - 1.0_jprb) zmaxerr(2) = max(zmaxerr(2), zerr(2)) enddo ! Vorticity do ifld = 1, nflevg zerr(3) = abs(znormvor1(ifld)/znormvor(ifld) - 1.0_jprb) zmaxerr(3) = max(zmaxerr(3),zerr(3)) enddo ! Temperature do ifld = 1, nflevg zerr(4) = abs(znormt1(ifld)/znormt(ifld) - 1.0_jprb) zmaxerr(4) = max(zmaxerr(4), zerr(4)) enddo write(nout,'("time step ",i6," took", f8.4," | zspvor max err="e10.3,& & " | zspdiv max err="e10.3," | zspsc3a max err="e10.3," | zspsc2 max err="e10.3)') & & jstep, ztstep(jstep), zmaxerr(3), zmaxerr(2), zmaxerr(4), zmaxerr(1) call gstats(6,1) else write(nout,'("Time step ",i6," took", f8.4)') jstep, ztstep(jstep) endif call gstats(3,1) enddo !=================================================================================================== ztloop = (timef() - ztloop)/1000.0_jprd write(nout,'(" ")') write(nout,'(a)') '======= End of spectral transforms =======' write(nout,'(" ")') if (lprint_norms .or. ncheck > 0) then call specnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset) call specnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset) call specnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt, kvset=ivset) call specnorm(pspec=zspsc2(1:1,:), pnorm=znormsp, kvset=ivsetsc) zmaxerr(:) = -999.0 do ifld = 1, nflevg zerr(3) = abs(real(znormvor1(ifld),kind=jprd)/real(znormvor(ifld),kind=jprd) - 1.0_jprd) zmaxerr(3) = max(zmaxerr(3), zerr(3)) if (verbosity >= 1) then write(nout,'("norm zspvor( ",i4,") = ",f20.15," error = ",e10.3)') ifld, znormvor1(ifld), zerr(3) endif enddo do ifld = 1, nflevg zerr(2) = abs(real(znormdiv1(ifld),kind=jprd)/real(znormdiv(ifld),kind=jprd) - 1.0d0) zmaxerr(2) = max(zmaxerr(2),zerr(2)) if (verbosity >= 1) then write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15," error = ",e10.3)') ifld, znormdiv1(ifld), zerr(2) endif enddo do ifld = 1, nflevg zerr(4) = abs(real(znormt1(ifld),kind=jprd)/real(znormt(ifld),kind=jprd) - 1.0d0) zmaxerr(4) = max(zmaxerr(4), zerr(4)) if (verbosity >= 1) then write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15," error = ",e10.3)') ifld, znormt1(ifld), zerr(4) endif enddo do ifld = 1, 1 zerr(1) = abs(real(znormsp1(ifld),kind=jprd)/real(znormsp(ifld),kind=jprd) - 1.0d0) zmaxerr(1) = max(zmaxerr(1), zerr(1)) if (verbosity >= 1) then write(nout,'("norm zspsc2( ",i4,",:) = ",f20.15," error = ",e10.3)') ifld, znormsp1(ifld), zerr(1) endif enddo ! maximum error across all fields zmaxerrg = max(max(zmaxerr(1),zmaxerr(2)), max(zmaxerr(2), zmaxerr(3))) if (verbosity >= 1) write(nout,*) write(nout,'("max error zspvor(1:nlev,:) = ",e10.3)') zmaxerr(3) write(nout,'("max error zspdiv(1:nlev,:) = ",e10.3)') zmaxerr(2) write(nout,'("max error zspsc3a(1:nlev,:,1) = ",e10.3)') zmaxerr(4) write(nout,'("max error zspsc2(1:1,:) = ",e10.3)') zmaxerr(1) write(nout,*) write(nout,'("max error combined = = ",e10.3)') zmaxerrg write(nout,*) if (ncheck > 0 .and. myproc == 1) then ! If the maximum spectral norm error across all fields is greater than 100 times the machine ! epsilon, fail the test if (zmaxerrg > real(ncheck, jprb) * epsilon(1.0_jprb)) then write(nout, '(a)') '*******************************' write(nout, '(a)') 'Correctness test failed' write(nout, '(a,1e7.2)') 'Maximum spectral norm error = ', zmaxerrg write(nout, '(a,1e7.2)') 'Error tolerance = ', real(ncheck, jprb) * epsilon(1.0_jprb) write(nout, '(a)') '*******************************' error stop endif endif endif if (luse_mpi) then call mpl_allreduce(ztloop, 'sum', ldreprod=.false.) call mpl_allreduce(ztstep, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin, 'min', ldreprod=.false.) call mpl_allreduce(ztstep1, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg1, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax1, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin1, 'min', ldreprod=.false.) call mpl_allreduce(ztstep2, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg2, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax2, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin2, 'min', ldreprod=.false.) endif ztstepavg = (ztstepavg/real(nproc,jprb))/real(iters,jprd) ztloop = ztloop/real(nproc,jprd) ztstep(:) = ztstep(:)/real(nproc,jprd) call sort(ztstep,iters) ztstepmed = ztstep(iters/2) ztstepavg1 = (ztstepavg1/real(nproc,jprb))/real(iters,jprd) ztstep1(:) = ztstep1(:)/real(nproc,jprd) call sort(ztstep1, iters) ztstepmed1 = ztstep1(iters/2) ztstepavg2 = (ztstepavg2/real(nproc,jprb))/real(iters,jprd) ztstep2(:) = ztstep2(:)/real(nproc,jprd) call sort(ztstep2,iters) ztstepmed2 = ztstep2(iters/2) write(nout,'(a)') '======= Start of time step stats =======' write(nout,'(" ")') write(nout,'("Inverse transforms")') write(nout,'("------------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg1 write(nout,'("min (s): ",f8.4)') ztstepmin1 write(nout,'("max (s): ",f8.4)') ztstepmax1 write(nout,'("med (s): ",f8.4)') ztstepmed1 write(nout,'(" ")') write(nout,'("Direct transforms")') write(nout,'("-----------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg2 write(nout,'("min (s): ",f8.4)') ztstepmin2 write(nout,'("max (s): ",f8.4)') ztstepmax2 write(nout,'("med (s): ",f8.4)') ztstepmed2 write(nout,'(" ")') write(nout,'("Inverse-direct transforms")') write(nout,'("-------------------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg write(nout,'("min (s): ",f8.4)') ztstepmin write(nout,'("max (s): ",f8.4)') ztstepmax write(nout,'("med (s): ",f8.4)') ztstepmed write(nout,'("loop (s): ",f8.4)') ztloop write(nout,'(" ")') write(nout,'(a)') '======= End of time step stats =======' write(nout,'(" ")') if (lstack) then ! Gather stack usage statistics istack = getstackusage() if (myproc == 1) then print 9000, istack 9000 format("Stack utilisation information",/,& &"=============================",//,& &"Task size(bytes)",/,& &"==== ===========",//,& &" 1",11x,i10) do i = 2, nproc call mpl_recv(istack, ksource=nprcids(i), ktag=i, cdstring='transform_test:') print '(i4,11x,i10)', i, istack enddo else call mpl_send(istack, kdest=nprcids(1), ktag=myproc, cdstring='transform_test:') endif endif !=================================================================================================== ! Cleanup !=================================================================================================== deallocate(zgmv) deallocate(zgmvs) !=================================================================================================== if (lstats) then call gstats(0,1) call gstats_print(nout, zaveave, jpmaxstat) endif if (lmeminfo) then write(nout,*) call ec_meminfo(nout, "", mpl_comm, kbarr=1, kiotask=-1, & & kcall=1) endif !=================================================================================================== ! Finalize MPI !=================================================================================================== if (luse_mpi) then call mpl_end(ldmeminfo=.false.) endif !=================================================================================================== ! Close file !=================================================================================================== if (nproc > 1) then if (myproc /= 1) then close(unit=nout) endif endif !=================================================================================================== contains !=================================================================================================== subroutine parse_grid(cgrid,ndgl,nloen) character(len=*), intent(in) :: cgrid integer, intent(inout) :: ndgl integer, intent(inout), allocatable :: nloen(:) integer :: ios integer :: gaussian_number read(cgrid(2:len_trim(cgrid)),*,IOSTAT=ios) gaussian_number if (ios==0) then ndgl = 2 * gaussian_number allocate(nloen(ndgl)) if (cgrid(1:1) == 'F') then ! Regular Gaussian grid nloen(:) = gaussian_number * 4 return endif if (cgrid(1:1) == 'O') then ! Octahedral Gaussian grid do i = 1, ndgl / 2 nloen(i) = 20 + 4 * (i - 1) nloen(ndgl - i + 1) = nloen(i) end do return endif endif call parsing_failed("ERROR: Unsupported grid specified: "// trim(cgrid)) end subroutine !=================================================================================================== subroutine str2int(str, int, stat) character(len=*), intent(in) :: str integer, intent(out) :: int integer, intent(out) :: stat read(str, *, iostat=stat) int end subroutine str2int !=================================================================================================== function get_int_value(cname, iarg) result(value) integer :: value character(len=*), intent(in) :: cname integer, intent(inout) :: iarg character(len=128) :: carg integer :: stat carg = get_str_value(cname, iarg) call str2int(carg, value, stat) if (stat /= 0) then call parsing_failed("Invalid argument for " // trim(cname) // ": " // trim(carg)) end if end function !=================================================================================================== function get_str_value(cname, iarg) result(value) character(len=128) :: value character(len=*), intent(in) :: cname integer, intent(inout) :: iarg iarg = iarg + 1 call get_command_argument(iarg, value) if (value == "") then call parsing_failed("Invalid argument for " // trim(cname) // ": no value provided") end if end function !=================================================================================================== subroutine print_help(unit) integer, optional :: unit integer, parameter :: nout = 6 if (present(unit)) then nout = unit endif write(nout, "(a)") "" if (jprb == jprd) then write(nout, "(a)") "NAME ectrans-benchmark-dp" else write(nout, "(a)") "NAME ectrans-benchmark-sp" end if write(nout, "(a)") "" write(nout, "(a)") "DESCRIPTION" write(nout, "(a)") " This program tests ecTrans by transforming fields back and forth& & between spectral " if (jprb == jprd) then write(nout, "(a)") " space and grid-point space (double-precision version)" else write(nout, "(a)") " space and grid-point space (single-precision version)" end if write(nout, "(a)") "" write(nout, "(a)") "USAGE" if (jprb == jprd) then write(nout, "(a)") " ectrans-benchmark-dp [options]" else write(nout, "(a)") " ectrans-benchmark-sp [options]" end if write(nout, "(a)") "" write(nout, "(a)") "OPTIONS" write(nout, "(a)") " -h, --help Print this message" write(nout, "(a)") " -v Run with verbose output" write(nout, "(a)") " -t, --truncation T Run with this triangular spectral truncation& & (default = 79)" write(nout, "(a)") " -g, --grid GRID Run with this grid. Possible values: O, F" write(nout, "(a)") " If not specified, O is used with N=truncation+1& & (cubic relation)" write(nout, "(a)") " -n, --niter NITER Run for this many inverse/direct transform& & iterations (default = 10)" write(nout, "(a)") " -f, --nfld NFLD Number of scalar fields (default = 1)" write(nout, "(a)") " -l, --nlev NLEV Number of vertical levels (default = 1)" write(nout, "(a)") " --vordiv Also transform vorticity-divergence to wind" write(nout, "(a)") " --scders Compute scalar derivatives (default off)" write(nout, "(a)") " --uvders Compute uv East-West derivatives (default off). Only& & when also --vordiv is given" write(nout, "(a)") " --flt Run with fast Legendre transforms (default off)" write(nout, "(a)") " --nproma NPROMA Run with NPROMA (default no blocking: NPROMA=ngptot)" write(nout, "(a)") " --norms Calculate and print spectral norms of transformed& & fields" write(nout, "(a)") " The computation of spectral norms will skew overall& & timings" write(nout, "(a)") " --meminfo Show diagnostic information from FIAT's ec_meminfo& & subroutine on memory usage, thread-binding etc." write(nout, "(a)") " --nprtrv Size of V set in spectral decomposition" write(nout, "(a)") " --nprtrw Size of W set in spectral decomposition" write(nout, "(a)") " -c, --check VALUE The multiplier of the machine epsilon used as a& & tolerance for correctness checking" write(nout, "(a)") "" write(nout, "(a)") "DEBUGGING" write(nout, "(a)") " --dump-values Output gridpoint fields in unformatted binary file" write(nout, "(a)") "" end subroutine print_help !=================================================================================================== subroutine parsing_failed(message) character(len=*), intent(in) :: message if (luse_mpi) call mpl_init(ldinfo=.false.) if (ec_mpirank() == 0) then write(nerr,"(a)") trim(message) call print_help(unit=nerr) endif if (luse_mpi) call mpl_end(ldmeminfo=.false.) stop end subroutine !=================================================================================================== subroutine get_command_line_arguments(nsmax, cgrid, iters, nfld, nlev, lvordiv, lscders, luvders, lgpnorms, & & luseflt, nproma, verbosity, ldump_values, lprint_norms, & & lmeminfo, nprtrv, nprtrw, ncheck) integer, intent(inout) :: nsmax ! Spectral truncation character(len=16), intent(inout) :: cgrid ! Spectral truncation integer, intent(inout) :: iters ! Number of iterations for transform test integer, intent(inout) :: nfld ! Number of scalar fields integer, intent(inout) :: nlev ! Number of vertical levels logical, intent(inout) :: lvordiv ! Also transform vorticity/divergence logical, intent(inout) :: lscders ! Compute scalar derivatives logical, intent(inout) :: luvders ! Compute uv East-West derivatives logical, intent(inout) :: lgpnorms ! calculate/print gpnorms logical, intent(inout) :: luseflt ! Use fast Legendre transforms integer, intent(inout) :: nproma ! NPROMA integer, intent(inout) :: verbosity ! Level of verbosity logical, intent(inout) :: ldump_values ! Dump values of grid point fields for debugging logical, intent(inout) :: lprint_norms ! Calculate and print spectral norms of fields logical, intent(inout) :: lmeminfo ! Show information from FIAT ec_meminfo routine at the ! end integer, intent(inout) :: nprtrv ! Size of V set (spectral decomposition) integer, intent(inout) :: nprtrw ! Size of W set (spectral decomposition) integer, intent(inout) :: ncheck ! The multiplier of the machine epsilon used as a ! tolerance for correctness checking character(len=128) :: carg ! Storage variable for command line arguments integer :: iarg ! Argument index integer :: stat ! For storing success status of string->integer conversion integer :: myproc iarg = 1 do while (iarg <= command_argument_count()) call get_command_argument(iarg, carg) select case(carg) ! Parse help argument case('-h', '--help') if (luse_mpi) call mpl_init(ldinfo=.false.) if (ec_mpirank()==0) call print_help() if (luse_mpi) call mpl_end(ldmeminfo=.false.) stop ! Parse verbosity argument case('-v') verbosity = 1 ! Parse number of iterations argument case('-n', '--niter') iters = get_int_value('-n', iarg) if (iters < 1) then call parsing_failed("Invalid argument for -n: must be > 0") end if ! Parse spectral truncation argument case('-t', '--truncation') nsmax = get_int_value('-t', iarg) if (nsmax < 1) then call parsing_failed("Invalid argument for -t: must be > 0") end if case('-g', '--grid'); cgrid = get_str_value('-g', iarg) case('-f', '--nfld'); nfld = get_int_value('-f', iarg) case('-l', '--nlev'); nlev = get_int_value('-l', iarg) case('--vordiv'); lvordiv = .True. case('--scders'); lscders = .True. case('--uvders'); luvders = .True. case('--lgpnorms'); lgpnorms = .True. case('--flt'); luseflt = .True. case('--nproma'); nproma = get_int_value('--nproma', iarg) case('--dump-values'); ldump_values = .true. case('--norms'); lprint_norms = .true. case('--meminfo'); lmeminfo = .true. case('--nprtrv'); nprtrv = get_int_value('--nprtrv', iarg) case('--nprtrw'); nprtrw = get_int_value('--nprtrw', iarg) case('-c', '--check'); ncheck = get_int_value('-c', iarg) case default call parsing_failed("Unrecognised argument: " // trim(carg)) end select iarg = iarg + 1 end do if (.not. lvordiv) then luvders = .false. endif end subroutine get_command_line_arguments !=================================================================================================== function cubic_octahedral_gaussian_grid(nsmax) result(cgrid) character(len=16) :: cgrid integer, intent(in) :: nsmax write(cgrid,'(a,i0)') 'O',nsmax+1 end function !=================================================================================================== subroutine sort(a, n) real(kind=jprd), intent(inout) :: a(n) integer(kind=jpim), intent(in) :: n real(kind=jprd) :: x integer :: i, j do i = 2, n x = a(i) j = i - 1 do while (j >= 1) if (a(j) <= x) exit a(j + 1) = a(j) j = j - 1 end do a(j + 1) = x end do end subroutine sort !=================================================================================================== subroutine initialize_spectral_arrays(nsmax, zsp, sp3d) integer, intent(in) :: nsmax ! Spectral truncation real(kind=jprb), intent(inout) :: zsp(:,:) ! Surface pressure real(kind=jprb), intent(inout) :: sp3d(:,:,:) ! 3D fields integer(kind=jpim) :: nflevl integer(kind=jpim) :: nfield integer :: i, j nflevl = size(sp3d, 1) nfield = size(sp3d, 3) ! First initialize surface pressure call initialize_2d_spectral_field(nsmax, zsp(1,:)) ! Then initialize all of the 3D fields do i = 1, nflevl do j = 1, nfield call initialize_2d_spectral_field(nsmax, sp3d(i,:,j)) end do end do end subroutine initialize_spectral_arrays !=================================================================================================== subroutine initialize_2d_spectral_field(nsmax, field) integer, intent(in) :: nsmax ! Spectral truncation real(kind=jprb), intent(inout) :: field(:) ! Field to initialize integer :: i, index, num_my_zon_wns integer, allocatable :: my_zon_wns(:), nasm0(:) ! Choose a spherical harmonic to initialize arrays integer, parameter :: m_num = 4 ! Zonal wavenumber integer, parameter :: l_num = 19 ! Total wavenumber ! First initialise all spectral coefficients to zero field(:) = 0.0 ! Get zonal wavenumbers this rank is responsible for call trans_inq(knump=num_my_zon_wns) allocate(my_zon_wns(num_my_zon_wns)) call trans_inq(kmyms=my_zon_wns) ! If rank is responsible for the chosen zonal wavenumber... if (any(my_zon_wns == m_num) ) then ! Get array of spectral array addresses (this maps (m, n=m) to array index) allocate(nasm0(0:nsmax)) call trans_inq(kasm0=nasm0) ! Find out local array index of chosen spherical harmonic index = nasm0(m_num) + 2 * (l_num - m_num) + 1 ! Set just that element to a constant value field(index) = 1.0 else return end if end subroutine initialize_2d_spectral_field !=================================================================================================== subroutine dump_gridpoint_field(jstep, myproc, nproma, ngpblks, fld, fldchar, noutdump) ! Dump a 2d field to a binary file. integer(kind=jpim), intent(in) :: jstep ! Time step, used for naming file integer(kind=jpim), intent(in) :: myproc ! MPI rank, used for naming file integer(kind=jpim), intent(in) :: nproma ! Size of nproma integer(kind=jpim), intent(in) :: ngpblks ! Number of nproma blocks real(kind=jprb) , intent(in) :: fld(nproma,ngpblks) ! 2D field character , intent(in) :: fldchar ! Single character field identifier integer(kind=jpim), intent(in) :: noutdump ! Tnit number for output file character(len=14), parameter :: filename = "x.xxx.xxxx.dat" write(filename(1:1),'(a1)') fldchar write(filename(3:5),'(i3.3)') jstep write(filename(7:10),'(i4.4)') myproc open(noutdump, file=filename, form="unformatted") write(noutdump) reshape(fld, (/ nproma*ngpblks /)) close(noutdump) end subroutine dump_gridpoint_field !=================================================================================================== function detect_mpirun() result(lmpi_required) logical :: lmpi_required integer :: ilen integer, parameter :: nvars = 5 character(len=32), dimension(nvars) :: cmpirun_detect character(len=4) :: clenv_dr_hook_assert_mpi_initialized integer :: ivar ! Environment variables that are set when mpirun, srun, aprun, ... are used cmpirun_detect(1) = 'OMPI_COMM_WORLD_SIZE' ! openmpi cmpirun_detect(2) = 'ALPS_APP_PE' ! cray pe cmpirun_detect(3) = 'PMI_SIZE' ! intel cmpirun_detect(4) = 'SLURM_NTASKS' ! slurm cmpirun_detect(5) = 'ECTRANS_USE_MPI' ! forced lmpi_required = .false. do ivar = 1, nvars call get_environment_variable(name=trim(cmpirun_detect(ivar)), length=ilen) if (ilen > 0) then lmpi_required = .true. exit ! break endif enddo end function !=================================================================================================== ! Assign GSTATS labels to the main regions of ecTrans subroutine gstats_labels call gstats_label(0, ' ', 'PROGRAM - Total') call gstats_label(1, ' ', 'SETUP_TRANS0 - Setup ecTrans') call gstats_label(2, ' ', 'SETUP_TRANS - Setup ecTrans handle') call gstats_label(3, ' ', 'TIME STEP - Time step') call gstats_label(4, ' ', 'INV_TRANS - Inverse transform') call gstats_label(5, ' ', 'DIR_TRANS - Direct transform') call gstats_label(6, ' ', 'NORMS - Norm comp. (optional)') call gstats_label(102, ' ', 'LTINV_CTL - Inv. Legendre transform') call gstats_label(103, ' ', 'LTDIR_CTL - Dir. Legendre transform') call gstats_label(106, ' ', 'FTDIR_CTL - Dir. Fourier transform') call gstats_label(107, ' ', 'FTINV_CTL - Inv. Fourier transform') call gstats_label(140, ' ', 'SULEG - Comp. of Leg. poly.') call gstats_label(152, ' ', 'LTINV_CTL - M to L transposition') call gstats_label(153, ' ', 'LTDIR_CTL - L to M transposition') call gstats_label(157, ' ', 'FTINV_CTL - L to G transposition') call gstats_label(158, ' ', 'FTDIR_CTL - G to L transposition') call gstats_label(400, ' ', 'GSTATS - GSTATS itself') end subroutine gstats_labels end program transform_test !=================================================================================================== ectrans-1.8.0/src/programs/ectrans-lam-benchmark.F900000664000175000017500000017376215174631767022443 0ustar alastairalastair! (C) Copyright 2001- ECMWF. ! (C) Copyright 2001- 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. ! program ectrans_lam_benchmark ! ! Spectral transform test for Limited-Area geometry ! ! This test performs spectral to real and real to spectral transforms repeated in ! timed loop. ! ! 1) One "surface" field is always transformed: ! zspsc2(1,1:nspec2) <-> zgmvs(1:nproma,1:1,1:ngbplk) ! ! 2) A Multiple "3d" fields are transformed and can be disabled with "--nfld 0" ! ! zspsc3a(1:nlev,1:nspec2,1:nfld) <-> zgp3a(1:nproma,1:nlev,1:nfld,1:ngpblk) ! ! 3) Optionally a "3d" vorticity/divergence field is transformed to uv (wind) and ! can be enabled with "--vordiv" ! ! zspvor(1:nlev,1:nspec2) / zspdiv(1:nlev,1:nspec2) <-> zgpuv(1:nproma,1:nlev,1:2,1:ngpblk) ! ! 4) Optionally scalar derivatives can be computed for the fields described in 1) and 2) ! This must be enabled with "--scders" ! ! 5) Optionally uv East-West derivate can be computed from vorticity/divergence. ! This must be enabled with "--vordiv --uvders" ! ! ! Authors : George Mozdzynski ! Willem Deconinck ! Ioan Hadade ! Sam Hatfield ! Daan Degrauwe use parkind1, only: jpim, jpib, jprb, jprd use oml_mod ,only : oml_max_threads use mpl_module use yomgstats, only: jpmaxstat use yomhook, only : dr_hook_init implicit none integer(kind=jpim) :: istack, getstackusage real(kind=jprb), dimension(1) :: zmaxerr(5), zerr(5) real(kind=jprb) :: zmaxerrg ! Output unit numbers integer(kind=jpim), parameter :: nerr = 0 ! Unit number for STDERR integer(kind=jpim), parameter :: nout = 6 ! Unit number for STDOUT integer(kind=jpim), parameter :: noutdump = 7 ! Unit number for field output ! Default parameters integer(kind=jpim) :: nlon = 128 ! Zonal dimension integer(kind=jpim) :: nlat = 128 ! Meridional dimension integer(kind=jpim) :: nsmax = 0 ! Spectral meridional truncation integer(kind=jpim) :: nmsmax = 0 ! Spectral zonal truncation integer(kind=jpim) :: iters = 10 ! Number of iterations for transform test integer(kind=jpim) :: nfld = 1 ! Number of scalar fields integer(kind=jpim) :: nlev = 1 ! Number of vertical levels integer(kind=jpim) :: nloen(1) ! only one value needed for LAM integer(kind=jpim) :: nflevg integer(kind=jpim) :: nspec2 integer(kind=jpim) :: ngptot integer(kind=jpim) :: ngptotg integer(kind=jpim) :: ifld integer(kind=jpim) :: jroc integer(kind=jpim) :: jb integer(kind=jpim) :: nspec2g integer(kind=jpim) :: i integer(kind=jpim) :: ja integer(kind=jpim) :: ib integer(kind=jpim) :: jprtrv integer(kind=jpim), allocatable :: nprcids(:) integer(kind=jpim) :: myproc, jj integer :: jstep real(kind=jprd), external :: timef ! Timing routine from FIAT real(kind=jprd) :: ztinit, ztloop, ztstepmax, ztstepmin, ztstepavg, ztstepmed real(kind=jprd) :: ztstepmax1, ztstepmin1, ztstepavg1, ztstepmed1 real(kind=jprd) :: ztstepmax2, ztstepmin2, ztstepavg2, ztstepmed2 real(kind=jprd), allocatable :: ztstep(:), ztstep1(:), ztstep2(:) real(kind=jprb), allocatable :: znormsp(:), znormsp0(:), znormdiv(:), znormdiv0(:) real(kind=jprb), allocatable :: znormvor(:), znormvor0(:), znormt(:), znormt0(:) real(kind=jprd) :: zaveave(0:jpmaxstat) ! Grid-point space data structures real(kind=jprb), pointer :: zgp3a (:,:,:,:) ! Multilevel fields at t and t-dt real(kind=jprb), pointer :: zgpuv (:,:,:,:) ! Multilevel fields at t and t-dt real(kind=jprb), pointer :: zgp2 (:,:,:) ! Single level fields at t and t-dt real(kind=jprb), allocatable :: zgp3a_ctg (:,:,:,:) ! Multilevel fields at t and t-dt real(kind=jprb), allocatable :: zgpuv_ctg (:,:,:,:) ! Multilevel fields at t and t-dt real(kind=jprb), allocatable :: zgp2_ctg (:,:,:) ! Single level fields at t and t-dt ! Spectral space data structures real(kind=jprb), allocatable, target :: sp3d(:,:,:) real(kind=jprb), pointer :: zspvor(:,:) => null() real(kind=jprb), pointer :: zspdiv(:,:) => null() real(kind=jprb), pointer :: zspsc3a(:,:,:) => null() real(kind=jprb), allocatable :: zspsc2(:,:) real(kind=jprb), allocatable :: zmeanu(:), zmeanv(:) logical :: lstack = .false. ! Output stack info logical :: luserpnm = .false. logical :: lkeeprpnm = .false. logical :: ltrace_stats = .false. logical :: lstats_omp = .false. logical :: lstats_comms = .false. logical :: lstats_mpl = .false. logical :: lstats = .false. ! gstats statistics logical :: lbarrier_stats = .false. logical :: lbarrier_stats2 = .false. logical :: ldetailed_stats = .false. logical :: lstats_alloc = .false. logical :: lsyncstats = .false. logical :: lstatscpu = .false. logical :: lstats_mem = .false. logical :: lxml_stats = .false. logical :: lfftw = .false. ! Use FFTW for Fourier transforms logical :: lvordiv = .false. logical :: lscders = .false. logical :: luvders = .false. logical :: lprint_norms = .false. ! Calculate and print spectral norms logical :: lmeminfo = .false. ! Show information from FIAT routine ec_meminfo at the end integer(kind=jpim) :: nstats_mem = 0 integer(kind=jpim) :: ntrace_stats = 0 integer(kind=jpim) :: nprnt_stats = 1 character(len=256) :: checksums_filename ! The multiplier of the machine epsilon used as a tolerance for correctness checking ! ncheck = 0 (the default) means that correctness checking is disabled integer(kind=jpim) :: ncheck = 0 logical :: lmpoff = .false. ! Message passing switch ! Verbosity level (0 or 1) integer :: verbosity = 0 integer(kind=jpim) :: nmax_resol = 37 ! Max number of resolutions integer(kind=jpim) :: npromatr = 0 ! nproma for trans lib integer(kind=jpim) :: nproc ! Number of procs integer(kind=jpim) :: nthread integer(kind=jpim) :: nprgpns = 0 ! Grid-point decomp integer(kind=jpim) :: nprgpew = 0 ! Grid-point decomp integer(kind=jpim) :: nprtrv = 0 ! Spectral decomp integer(kind=jpim) :: nprtrw = 0 ! Spectral decomp integer(kind=jpim) :: nspecresmin = 80 ! Minimum spectral resolution, for controlling nprtrw integer(kind=jpim) :: mysetv integer(kind=jpim) :: mysetw integer(kind=jpim) :: mp_type = 2 ! Message passing type integer(kind=jpim) :: mbx_size = 150000000 ! Mailbox size integer(kind=jpim), allocatable :: numll(:), ivset(:) integer(kind=jpim) :: ivsetsc(1) integer(kind=jpim) :: nflevl ! sumpini integer(kind=jpim) :: isqr logical :: lsync_trans = .false. ! Activate barrier sync integer(kind=jpim) :: nproma = 0 integer(kind=jpim) :: ngpblks ! locals integer(kind=jpim) :: iprtrv integer(kind=jpim) :: iprtrw integer(kind=jpim) :: iprused, ilevpp, irest, ilev, jlev integer(kind=jpim) :: ndimgmv = 0 ! Third dim. of gmv "(nproma,nflevg,ndimgmv,ngpblks)" integer(kind=jpim) :: ndimgmvs = 0 ! Second dim. gmvs "(nproma,ndimgmvs,ngpblks)" integer(kind=jpim) :: jbegin_uv = 0 integer(kind=jpim) :: jend_uv = 0 integer(kind=jpim) :: jbegin_sc = 0 integer(kind=jpim) :: jend_sc = 0 integer(kind=jpim) :: jbegin_scder_NS = 0 integer(kind=jpim) :: jend_scder_NS = 0 integer(kind=jpim) :: jbegin_scder_EW = 0 integer(kind=jpim) :: jend_scder_EW = 0 integer(kind=jpim) :: jbegin_uder_EW = 0 integer(kind=jpim) :: jend_uder_EW = 0 integer(kind=jpim) :: jbegin_vder_EW = 0 integer(kind=jpim) :: jend_vder_EW = 0 integer(kind=jpim) :: iend = 0 logical :: ldump_values = .false. logical :: ldump_checksums = .false. logical :: luse_mpi = .true. integer, external :: ec_mpirank character(len=128) :: cchecksums_path = '' integer(kind=jpim) :: ierr real(kind=jprb) :: zexwn, zeywn !=================================================================================================== #include "setup_trans0.h" #include "esetup_trans.h" #include "einv_trans.h" #include "edir_trans.h" #include "etrans_end.h" #include "etrans_inq.h" #include "especnorm.h" #include "egath_grid.h" #include "egath_spec.h" #include "abor1.intfb.h" #include "gstats_setup.intfb.h" #include "ec_meminfo.intfb.h" !=================================================================================================== luse_mpi = detect_mpirun() ! Setup call get_command_line_arguments(nlon, nlat, nsmax, nmsmax, iters, nfld, nlev, lvordiv, lscders, luvders, & & nproma, verbosity, ldump_values, ldump_checksums, lprint_norms, lmeminfo, & & nprgpns, nprgpew, nprtrv, nprtrw, ncheck,cchecksums_path) ! derived defaults if ( nsmax == 0 ) nsmax = nlat/2-1 if ( nmsmax == 0 ) nmsmax = nlon/2-1 nflevg = nlev !=================================================================================================== if (luse_mpi) then call mpl_init(ldinfo=(verbosity>=1)) nproc = mpl_nproc() myproc = mpl_myrank() else nproc = 1 myproc = 1 mpl_comm = -1 endif nthread = oml_max_threads() call dr_hook_init() !=================================================================================================== if( lstats ) call gstats(0,0) ztinit = timef() / 1000.0_jprd ! only output to stdout on pe 1 !if (nproc > 1) then !if (myproc /= 1) then !open(unit=nout, file='output_'//char(myproc/10+48)//char(myproc+48)//'.dat') !endif !endif if (ldetailed_stats) then lstats_omp = .true. lstats_comms = .true. lstats_mpl = .true. lstatscpu = .true. nprnt_stats = nproc lstats_mem = .true. lstats_alloc = .true. endif !=================================================================================================== allocate(nprcids(nproc)) do jj = 1, nproc nprcids(jj) = jj enddo if (nproc <= 1) then lmpoff = .true. endif ! Compute nprgpns and nprgpew ! This version selects most square-like distribution if (nproc == 0) nproc = 1 if ( nprgpew == 0 .and. nprgpns == 0 ) then isqr = int(sqrt(real(nproc,jprb))) do ja = isqr, nproc ib = nproc/ja if (ja*ib == nproc) then nprgpns = max(ja,ib) nprgpew = min(ja,ib) exit endif enddo elseif (nprgpns == 0 ) then nprgpns=nproc/nprgpew elseif (nprgpew == 0 ) then nprgpew=nproc/nprgpns endif if (nprgpns*nprgpew /= nproc) call abor1('transform_test:nprgpns*nprgpew /= nproc') ! From sumpini, although this should be specified in namelist if (nspecresmin == 0) nspecresmin = nproc ! Compute nprtrv and nprtrw if not provided on the command line if (nprtrv ==0 .and. nprtrw == 0 ) then nprtrv=nprgpew nprtrw=nprgpns elseif (nprtrv == 0 ) then nprtrv=nproc/nprtrw elseif (nprtrw == 0 ) then nprtrw=nproc/nprtrv endif if (nprtrv*nprtrw /= nproc) call abor1('transform_test:nprtrv*nprtrw /= nproc') mysetv=mod(myproc-1,nprtrv)+1 ! Determine number of local levels for zonal and meridional fourier calculations ! based on the values of nflevg and nprtrv allocate(numll(nprtrv)) numll=nflevg/nprtrv numll(1:modulo(nflevg,nprtrv))=numll(1:modulo(nflevg,nprtrv))+1 ivsetsc(1)=min(nflevg+1, nprtrv) nflevl = numll(mysetv) !=================================================================================================== ! Setup gstats !=================================================================================================== if (lstats) then call gstats_setup(nproc, myproc, nprcids, & & lstats, lstatscpu, lsyncstats, ldetailed_stats, lbarrier_stats, lbarrier_stats2, & & lstats_omp, lstats_comms, lstats_mem, nstats_mem, lstats_alloc, & & ltrace_stats, ntrace_stats, nprnt_stats, lxml_stats) call gstats_psut ! Assign labels to GSTATS regions call gstats_labels endif !=================================================================================================== ! Call ecTrans setup routines !=================================================================================================== if (verbosity >= 1) write(nout,'(a)')'======= Setup ecTrans =======' if( lstats ) call gstats(1, 0) call setup_trans0(kout=nout, kerr=nerr, kprintlev=merge(2, 0, verbosity == 1), & & kmax_resol=nmax_resol, kpromatr=0, kprgpns=nprgpns, kprgpew=nprgpew, & & kprtrw=nprtrw, ldsync_trans=lsync_trans, & & ldalloperm=.true., ldmpoff=.not.luse_mpi) if( lstats ) call gstats(1, 1) if( lstats ) call gstats(2, 0) zexwn=1._jprb ! 2*pi/(nx*dx): spectral resolution zeywn=1._jprb ! 2*pi/(ny*dy) nloen=nlon call esetup_trans(ksmax=nsmax, kmsmax=nmsmax, kdgl=nlat, kdgux=nlat, kloen=nloen, ldsplit=.true., & & ldusefftw=lfftw,pexwn=zexwn,peywn=zeywn) if( lstats ) call gstats(2, 1) call etrans_inq(kspec2=nspec2, kspec2g=nspec2g, kgptot=ngptot, kgptotg=ngptotg) if (nproma == 0) then ! no blocking (default when not specified) nproma = ngptot endif ! Calculate number of NPROMA blocks ngpblks = (ngptot - 1)/nproma+1 !=================================================================================================== ! Print information before starting !=================================================================================================== ! Print configuration details if (verbosity >= 0) then write(nout,'(" ")') write(nout,'(a)')'======= Start of runtime parameters =======' write(nout,'(" ")') write(nout,'("nlon ",i0)') nlon write(nout,'("nlat ",i0)') nlat write(nout,'("nsmax ",i0)') nsmax write(nout,'("nmsmax ",i0)') nmsmax write(nout,'("nproc ",i0)') nproc write(nout,'("nthread ",i0)') nthread write(nout,'("nprgpns ",i0)') nprgpns write(nout,'("nprgpew ",i0)') nprgpew write(nout,'("nprtrw ",i0)') nprtrw write(nout,'("nprtrv ",i0)') nprtrv write(nout,'("ngptot ",i0)') ngptot write(nout,'("ngptotg ",i0)') ngptotg write(nout,'("nfld ",i0)') nfld write(nout,'("nlev ",i0)') nlev write(nout,'("nflevl ",i0)') nflevl write(nout,'("nproma ",i0)') nproma write(nout,'("ngpblks ",i0)') ngpblks write(nout,'("nspec2 ",i0)') nspec2 write(nout,'("nspec2g ",i0)') nspec2g write(nout,'("lvordiv ",l)') lvordiv write(nout,'("lscders ",l)') lscders write(nout,'("luvders ",l)') luvders write(nout,'(" ")') write(nout,'(a)') '======= End of runtime parameters =======' write(nout,'(" ")') end if !=================================================================================================== ! Allocate and Initialize spectral arrays !=================================================================================================== ! Allocate spectral arrays ! Try to mimick IFS layout as much as possible nullify(zspvor) nullify(zspdiv) nullify(zspsc3a) allocate(sp3d(nflevl,nspec2,2+nfld)) allocate(zspsc2(1,nspec2)) allocate(zmeanu(nflevl),zmeanv(nflevl)) zmeanu(:)=0._jprb zmeanv(:)=0._jprb call initialize_spectral_arrays(nsmax, nmsmax, zspsc2, sp3d) ! Point convenience variables to storage variable sp3d zspvor => sp3d(:,:,1) zspdiv => sp3d(:,:,2) zspsc3a => sp3d(:,:,3:3+(nfld-1)) !=================================================================================================== ! Allocate gridpoint arrays !=================================================================================================== allocate(ivset(nflevg)) ! Compute spectral distribution ilev = 0 do jb = 1, nprtrv do jlev=1, numll(jb) ilev = ilev + 1 ivset(ilev) = jb enddo enddo ! Allocate grid-point arrays if (lvordiv) then jbegin_uv = 1 jend_uv = 2 endif if (luvders) then jbegin_uder_EW = jend_uv + 1 jend_uder_EW = jbegin_uder_EW + 1 jbegin_vder_EW = jend_uder_EW + 1 jend_vder_EW = jbegin_vder_EW + 1 else jbegin_uder_EW = jend_uv jend_uder_EW = jend_uv jbegin_vder_EW = jend_uv jend_vder_EW = jend_uv endif jbegin_sc = jend_vder_EW + 1 jend_sc = jend_vder_EW + nfld if (lscders) then ndimgmvs = 3 jbegin_scder_NS = jend_sc + 1 jend_scder_NS = jend_sc + nfld jbegin_scder_EW = jend_scder_NS + 1 jend_scder_EW = jend_scder_NS + nfld else ndimgmvs = 1 jbegin_scder_NS = jend_sc jend_scder_NS = jend_sc jbegin_scder_EW = jend_sc jend_scder_EW = jend_sc endif ndimgmv = jend_scder_EW ! allocate separately since non-contiguous host-device transfers are not supported. allocate(zgpuv(nproma,nflevg,jend_vder_EW,ngpblks)) allocate(zgp3a(nproma,nflevg,jend_scder_EW-jbegin_sc+1,ngpblks)) allocate(zgp2(nproma,ndimgmvs,ngpblks)) zgp2=0. zgp3a=0. zgpuv=0. !=================================================================================================== ! Allocate norm arrays !=================================================================================================== if (lprint_norms .or. ncheck > 0) then allocate(znormsp(1)) allocate(znormsp0(1)) allocate(znormvor(nflevg)) allocate(znormvor0(nflevg)) allocate(znormdiv(nflevg)) allocate(znormdiv0(nflevg)) allocate(znormt(nflevg)) allocate(znormt0(nflevg)) if ( lvordiv ) then call especnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor0, kvset=ivset(1:nflevg)) call especnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv0, kvset=ivset(1:nflevg)) endif if ( nfld>0 ) then call especnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt0, kvset=ivset(1:nflevg)) endif call especnorm(pspec=zspsc2(1:1,:), pnorm=znormsp0, kvset=ivsetsc) if (verbosity >= 1 .and. myproc == 1) then if ( lvordiv ) then do ifld = 1, nflevg write(nout,'("norm zspvor( ",i4,",:) = ",f20.15)') ifld, znormvor0(ifld) enddo do ifld = 1, nflevg write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15)') ifld, znormdiv0(ifld) enddo endif if ( nfld>0 ) then do ifld = 1, nflevg write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15)') ifld, znormt0(ifld) enddo endif do ifld = 1, 1 write(nout,'("norm zspsc2( ",i4,",:) = ",f20.15)') ifld, znormsp0(ifld) enddo endif endif !=================================================================================================== ! Setup timers !=================================================================================================== ztinit = (timef() / 1000.0_jprd - ztinit) if (verbosity >= 0) then write(nout,'(" ")') write(nout,'(a,i6,a,f9.2,a)') "transform_test initialisation, on",nproc,& & " tasks, took",ztinit," sec" write(nout,'(" ")') endif if (iters <= 0) call abor1('transform_test:iters <= 0') allocate(ztstep(iters)) allocate(ztstep1(iters)) allocate(ztstep2(iters)) ztstepavg = 0._jprd ztstepmax = 0._jprd ztstepmin = 9999999999999999._jprd ztstepavg1 = 0._jprd ztstepmax1 = 0._jprd ztstepmin1 = 9999999999999999._jprd ztstepavg2 = 0._jprd ztstepmax2 = 0._jprd ztstepmin2 = 9999999999999999._jprd !================================================================================================= ! Dump the values to disk, for debugging only !================================================================================================= if (ldump_values) then ! dump a field to a binary file call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspsc2(1,:),ivsetsc(1:1), 'S', noutdump) if ( lvordiv ) then call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspdiv(1,:),ivset(1:1), 'D', noutdump) call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspvor(1,:),ivset(1:1), 'V', noutdump) endif if ( nfld>0 ) then call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspsc3a(1,:,1),ivset(1:1), 'T', noutdump) endif endif write(nout,'(a)') '======= Start of spectral transforms =======' write(nout,'(" ")') ztloop = timef() / 1000.0_jprd !=================================================================================================== ! Do spectral transform loop !=================================================================================================== do jstep = 1, iters if( lstats ) call gstats(3,0) ztstep(jstep) = timef() / 1000.0_jprd !================================================================================================= ! Do inverse transform !================================================================================================= ztstep1(jstep) = timef() / 1000.0_jprd if( lstats ) call gstats(4,0) if (lvordiv) then call einv_trans(kresol=1, kproma=nproma, & & pspsc2=zspsc2, & ! spectral surface pressure & pspvor=zspvor, & ! spectral vorticity & pspdiv=zspdiv, & ! spectral divergence & pspsc3a=zspsc3a, & ! spectral scalars & ldscders=lscders, & & ldvorgp=.false., & ! no gridpoint vorticity & lddivgp=.false., & ! no gridpoint divergence & lduvder=luvders, & & kvsetuv=ivset, & & kvsetsc2=ivsetsc, & & kvsetsc3a=ivset, & & pgp2=zgp2, & & pgpuv=zgpuv, & & pgp3a=zgp3a, & & pmeanu=zmeanu, & & pmeanv=zmeanv) else call einv_trans(kresol=1, kproma=nproma, & & pspsc2=zspsc2, & ! spectral surface pressure & pspsc3a=zspsc3a, & ! spectral scalars & ldscders=lscders, & ! scalar derivatives & kvsetsc2=ivsetsc, & & kvsetsc3a=ivset, & & pgp2=zgp2, & & pgp3a=zgp3a) endif if( lstats ) call gstats(4,1) if (ldump_checksums) then ! Remove trash at end of last block iend = ngptot - nproma * (ngpblks - 1) zgp2 (iend+1:, :, ngpblks) = 0 write (checksums_filename,'(A)') trim(cchecksums_path)//'_inv_trans.checksums' call dump_checksums(filename = checksums_filename, noutdump = noutdump, & & jstep = jstep, myproc = myproc, nproma = nproma, ngptotg = ngptotg, & & ivset = ivset, ivsetsc = ivsetsc, & & nspec2g = nspec2g, zgpuv = zgpuv, zgp3a = zgpuv, zgp2 = zgp2) endif ztstep1(jstep) = (timef() / 1000.0_jprd - ztstep1(jstep)) !================================================================================================= ! While in grid point space, dump the values to disk, for debugging only !================================================================================================= if (ldump_values) then ! dump a field to a binary file call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgp2(:,1,:), 'S', noutdump) if ( lvordiv ) then call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgpuv(:,nflevg,1,:), 'U', noutdump) call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgpuv(:,nflevg,2,:), 'V', noutdump) endif if ( nfld>0 ) then call dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, zgp3a(:,nflevg,1,:), 'T', noutdump) endif endif !================================================================================================= ! Do direct transform !================================================================================================= ztstep2(jstep) = timef() / 1000.0_jprd if( lstats ) call gstats(5,0) ! take local copies to make them contiguous; this is not the case when derivatives are requested and nproma0 ) then call dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, zspsc3a(1,:,1),ivset(1:1), 'T', noutdump) endif endif if (ldump_checksums) then write (checksums_filename,'(A)') trim(cchecksums_path)//'_dir_trans.checksums' call dump_checksums(filename = checksums_filename, noutdump = noutdump, & & jstep = jstep, myproc = myproc, nproma = nproma, ngptotg = ngptotg, & & ivset = ivset, ivsetsc = ivsetsc, & & nspec2g = nspec2g, sp3d = sp3d, zspc2 = zspsc2) endif !================================================================================================= ! Calculate timings !================================================================================================= ztstep(jstep) = (timef() / 1000.0_jprd - ztstep(jstep)) ztstepavg = ztstepavg + ztstep(jstep) ztstepmin = min(ztstep(jstep), ztstepmin) ztstepmax = max(ztstep(jstep), ztstepmax) ztstepavg1 = ztstepavg1 + ztstep1(jstep) ztstepmin1 = min(ztstep1(jstep), ztstepmin1) ztstepmax1 = max(ztstep1(jstep), ztstepmax1) ztstepavg2 = ztstepavg2 + ztstep2(jstep) ztstepmin2 = min(ztstep2(jstep), ztstepmin2) ztstepmax2 = max(ztstep2(jstep), ztstepmax2) !================================================================================================= ! Print norms !================================================================================================= if (lprint_norms) then if( lstats ) call gstats(6,0) call especnorm(pspec=zspsc2(1:1,:), pnorm=znormsp, kvset=ivsetsc(1:1)) if ( lvordiv ) then call especnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset(1:nflevg)) call especnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset(1:nflevg)) endif if ( nfld>0 ) then call especnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt, kvset=ivset(1:nflevg)) endif if ( myproc == 1 ) then zmaxerr(:) = -999.0 ! Surface pressure do ifld = 1, 1 zerr(1) = abs(znormsp(ifld)/znormsp0(ifld) - 1.0_jprb) zmaxerr(1) = max(zmaxerr(1), zerr(1)) enddo if ( lvordiv ) then ! Divergence do ifld = 1, nflevg zerr(2) = abs(znormdiv(ifld)/znormdiv0(ifld) - 1.0_jprb) zmaxerr(2) = max(zmaxerr(2), zerr(2)) enddo ! Vorticity do ifld = 1, nflevg zerr(3) = abs(znormvor(ifld)/znormvor0(ifld) - 1.0_jprb) zmaxerr(3) = max(zmaxerr(3),zerr(3)) enddo else zmaxerr(2:3)=0.0_jprb endif if ( nfld>0 ) then ! Temperature do ifld = 1, nflevg zerr(4) = abs(znormt(ifld)/znormt0(ifld) - 1.0_jprb) zmaxerr(4) = max(zmaxerr(4), zerr(4)) enddo else zmaxerr(4)=0.0_jprb endif if ( lvordiv ) then if ( nfld > 0 ) then write(nout,'("time step ",i6," took", f8.4," | zspvor max err="e10.3,& & " | zspdiv max err="e10.3," | zspsc3a max err="e10.3," | zspsc2 max err="e10.3)') & & jstep, ztstep(jstep), zmaxerr(3), zmaxerr(2), zmaxerr(4), zmaxerr(1) else write(nout,'("time step ",i6," took", f8.4," | zspvor max err="e10.3,& & " | zspdiv max err="e10.3," | zspsc2 max err="e10.3)') & & jstep, ztstep(jstep), zmaxerr(3), zmaxerr(2), zmaxerr(1) endif else if ( nfld > 0 ) then write(nout,'("time step ",i6," took", f8.4," | zspsc3a max err="e10.3," | zspsc2 max err="e10.3)') & & jstep, ztstep(jstep), zmaxerr(4), zmaxerr(1) else write(nout,'("time step ",i6," took", f8.4," | zspsc2 max err="e10.3)') & & jstep, ztstep(jstep), zmaxerr(1) endif endif if( lstats )call gstats(6,1) else write(nout,'("Time step ",i6," took", f8.4)') jstep, ztstep(jstep) endif endif if( lstats ) call gstats(3,1) enddo !=================================================================================================== ztloop = (timef() / 1000.0_jprd - ztloop) write(nout,'(" ")') write(nout,'(a)') '======= End of spectral transforms =======' write(nout,'(" ")') if (lprint_norms .or. ncheck > 0) then if ( lvordiv ) then call especnorm(pspec=zspvor(1:nflevl,:), pnorm=znormvor, kvset=ivset) call especnorm(pspec=zspdiv(1:nflevl,:), pnorm=znormdiv, kvset=ivset) endif if ( nfld>0 ) then call especnorm(pspec=zspsc3a(1:nflevl,:,1), pnorm=znormt, kvset=ivset) endif call especnorm(pspec=zspsc2(1:1,:), pnorm=znormsp, kvset=ivsetsc) if ( myproc == 1 ) then zmaxerr(:) = -999.0 if ( lvordiv ) then do ifld = 1, nflevg zerr(3) = abs(real(znormvor(ifld),kind=jprd)/real(znormvor0(ifld),kind=jprd) - 1.0_jprd) zmaxerr(3) = max(zmaxerr(3), zerr(3)) if (verbosity >= 1) then write(nout,'("norm zspvor( ",i4,") = ",f20.15," error = ",e10.3)') & & ifld, znormvor0(ifld), zerr(3) endif enddo do ifld = 1, nflevg zerr(2) = abs(real(znormdiv(ifld),kind=jprd)/real(znormdiv0(ifld),kind=jprd) - 1.0d0) zmaxerr(2) = max(zmaxerr(2),zerr(2)) if (verbosity >= 1) then write(nout,'("norm zspdiv( ",i4,",:) = ",f20.15," error = ",e10.3)') & & ifld, znormdiv0(ifld), zerr(2) endif enddo endif if ( nfld>0 ) then do ifld = 1, nflevg zerr(4) = abs(real(znormt(ifld),kind=jprd)/real(znormt0(ifld),kind=jprd) - 1.0d0) zmaxerr(4) = max(zmaxerr(4), zerr(4)) if (verbosity >= 1) then write(nout,'("norm zspsc3a(",i4,",:,1) = ",f20.15," error = ",e10.3)') & & ifld, znormt0(ifld), zerr(4) endif enddo endif do ifld = 1, 1 zerr(1) = abs(real(znormsp(ifld),kind=jprd)/real(znormsp0(ifld),kind=jprd) - 1.0d0) zmaxerr(1) = max(zmaxerr(1), zerr(1)) if (verbosity >= 1) then write(nout,'("norm zspsc2( ",i4,",:) = ",f20.15," error = ",e10.3)') & & ifld, znormsp0(ifld), zerr(1) endif enddo ! maximum error across all fields zmaxerrg = max(max(zmaxerr(1),zmaxerr(2)), max(zmaxerr(3), zmaxerr(4))) if (verbosity >= 1) then write(nout,*) if ( lvordiv ) then write(nout,'("max error zspvor(1:nlev,:) = ",e10.3)') zmaxerr(3) write(nout,'("max error zspdiv(1:nlev,:) = ",e10.3)') zmaxerr(2) endif if ( nfld> 0 ) then write(nout,'("max error zspsc3a(1:nlev,:,1) = ",e10.3)') zmaxerr(4) endif write(nout,'("max error zspsc2(1:1,:) = ",e10.3)') zmaxerr(1) write(nout,*) write(nout,'("max error combined = = ",e10.3)') zmaxerrg write(nout,*) endif if (ncheck > 0) then ! If the maximum spectral norm error across all fields is greater than 100 times the machine ! epsilon, fail the test if (zmaxerrg > real(ncheck, jprb) * epsilon(1.0_jprb)) then write(nout, '(a)') '*******************************' write(nout, '(a)') 'Correctness test failed' write(nout, '(a,1e7.2)') 'Maximum spectral norm error = ', zmaxerrg write(nout, '(a,1e7.2)') 'Error tolerance = ', real(ncheck, jprb) * epsilon(1.0_jprb) write(nout, '(a)') '*******************************' error stop endif endif endif endif if (luse_mpi) then call mpl_allreduce(ztloop, 'sum', ldreprod=.false.) call mpl_allreduce(ztstep, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin, 'min', ldreprod=.false.) call mpl_allreduce(ztstep1, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg1, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax1, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin1, 'min', ldreprod=.false.) call mpl_allreduce(ztstep2, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepavg2, 'sum', ldreprod=.false.) call mpl_allreduce(ztstepmax2, 'max', ldreprod=.false.) call mpl_allreduce(ztstepmin2, 'min', ldreprod=.false.) endif ztstepavg = (ztstepavg/real(nproc,jprb))/real(iters,jprd) ztloop = ztloop/real(nproc,jprd) ztstep(:) = ztstep(:)/real(nproc,jprd) call sort(ztstep,iters) ztstepmed = ztstep(iters/2) ztstepavg1 = (ztstepavg1/real(nproc,jprb))/real(iters,jprd) ztstep1(:) = ztstep1(:)/real(nproc,jprd) call sort(ztstep1, iters) ztstepmed1 = ztstep1(iters/2) ztstepavg2 = (ztstepavg2/real(nproc,jprb))/real(iters,jprd) ztstep2(:) = ztstep2(:)/real(nproc,jprd) call sort(ztstep2,iters) ztstepmed2 = ztstep2(iters/2) write(nout,'(a)') '======= Start of time step stats =======' write(nout,'(" ")') write(nout,'("Inverse transforms")') write(nout,'("------------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg1 write(nout,'("min (s): ",f8.4)') ztstepmin1 write(nout,'("max (s): ",f8.4)') ztstepmax1 write(nout,'("med (s): ",f8.4)') ztstepmed1 write(nout,'(" ")') write(nout,'("Direct transforms")') write(nout,'("-----------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg2 write(nout,'("min (s): ",f8.4)') ztstepmin2 write(nout,'("max (s): ",f8.4)') ztstepmax2 write(nout,'("med (s): ",f8.4)') ztstepmed2 write(nout,'(" ")') write(nout,'("Inverse-direct transforms")') write(nout,'("-------------------------")') write(nout,'("avg (s): ",f8.4)') ztstepavg write(nout,'("min (s): ",f8.4)') ztstepmin write(nout,'("max (s): ",f8.4)') ztstepmax write(nout,'("med (s): ",f8.4)') ztstepmed write(nout,'("loop (s): ",f8.4)') ztloop write(nout,'(" ")') write(nout,'(a)') '======= End of time step stats =======' write(nout,'(" ")') if (lstack) then ! Gather stack usage statistics istack = getstackusage() if (myproc == 1) then print 9000, istack 9000 format("Stack utilisation information",/,& &"=============================",//,& &"Task size(bytes)",/,& &"==== ===========",//,& &" 1",11x,i10) do i = 2, nproc call mpl_recv(istack, ksource=nprcids(i), ktag=i, cdstring='transform_test:') print '(i4,11x,i10)', i, istack enddo else call mpl_send(istack, kdest=nprcids(1), ktag=myproc, cdstring='transform_test:') endif endif !=================================================================================================== ! Cleanup !=================================================================================================== deallocate(nprcids,numll) deallocate(sp3d,zspsc2,zmeanu,zmeanv) deallocate(ivset) deallocate(zgpuv,zgp3a,zgp2) if ( allocated(znormsp) ) deallocate(znormsp,znormsp0,znormvor,znormvor0,znormdiv,znormdiv0,znormt,znormt0) deallocate(ztstep,ztstep1,ztstep2) call etrans_end() !=================================================================================================== if (lstats) then call gstats(0,1) call gstats_print(nout, zaveave, jpmaxstat) endif if (lmeminfo) then write(nout,*) call ec_meminfo(nout, "", mpl_comm, kbarr=1, kiotask=-1, & & kcall=1) endif !=================================================================================================== ! Finalize MPI !=================================================================================================== if (luse_mpi) then call mpl_end(ldmeminfo=.false.) endif !=================================================================================================== ! Close file !=================================================================================================== if (nproc > 1) then if (myproc /= 1) then close(unit=nout) endif endif !=================================================================================================== contains !=================================================================================================== function get_int_value(cname, iarg) result(value) integer :: value character(len=*), intent(in) :: cname integer, intent(inout) :: iarg character(len=128) :: carg integer :: stat carg = get_str_value(cname, iarg) call str2int(carg, value, stat) if (stat /= 0) then call parsing_failed("Invalid argument for " // trim(cname) // ": " // trim(carg)) end if end function !=================================================================================================== function get_str_value(cname, iarg) result(value) character(len=128) :: value character(len=*), intent(in) :: cname integer, intent(inout) :: iarg iarg = iarg + 1 call get_command_argument(iarg, value) if (value == "") then call parsing_failed("Invalid argument for " // trim(cname) // ": no value provided") end if end function !=================================================================================================== subroutine parsing_failed(message) character(len=*), intent(in) :: message if (luse_mpi) call mpl_init(ldinfo=.false.) if (ec_mpirank() == 0) then write(nerr,"(a)") trim(message) call print_help(unit=nerr) endif if (luse_mpi) call mpl_end(ldmeminfo=.false.) error stop end subroutine !=================================================================================================== subroutine get_command_line_arguments(nlon, nlat, nsmax, nmsmax, & & iters, nfld, nlev, lvordiv, lscders, luvders, & & nproma, verbosity, ldump_values, ldump_checksums, lprint_norms, & & lmeminfo, nprgpns, nprgpew, nprtrv, nprtrw, ncheck,cchecksums_path) integer, intent(inout) :: nlon ! Zonal dimension integer, intent(inout) :: nlat ! Meridional dimension integer, intent(inout) :: nsmax ! Meridional truncation integer, intent(inout) :: nmsmax ! Zonal trunciation integer, intent(inout) :: iters ! Number of iterations for transform test integer, intent(inout) :: nfld ! Number of scalar fields integer, intent(inout) :: nlev ! Number of vertical levels logical, intent(inout) :: lvordiv ! Also transform vorticity/divergence logical, intent(inout) :: lscders ! Compute scalar derivatives logical, intent(inout) :: luvders ! Compute uv East-West derivatives integer, intent(inout) :: nproma ! NPROMA integer, intent(inout) :: verbosity ! Level of verbosity logical, intent(inout) :: ldump_values ! Dump values of grid point fields for debugging logical, intent(inout) :: ldump_checksums ! Dump CRC checksums logical, intent(inout) :: lprint_norms ! Calculate and print spectral norms of fields logical, intent(inout) :: lmeminfo ! Show information from FIAT ec_meminfo routine at the ! end integer, intent(inout) :: nprgpns ! Size of NS set (gridpoint decomposition) integer, intent(inout) :: nprgpew ! Size of EW set (gridpoint decomposition) integer, intent(inout) :: nprtrv ! Size of V set (spectral decomposition) integer, intent(inout) :: nprtrw ! Size of W set (spectral decomposition) integer, intent(inout) :: ncheck ! The multiplier of the machine epsilon used as a ! tolerance for correctness checking character(len=128), intent(inout) :: cchecksums_path ! path to export checksum files character(len=128) :: carg ! Storage variable for command line arguments integer :: iarg ! Argument index integer :: stat ! For storing success status of string->integer conversion integer :: myproc iarg = 1 do while (iarg <= command_argument_count()) call get_command_argument(iarg, carg) select case(carg) ! Parse help argument case('-h', '--help') if (luse_mpi) call mpl_init(ldinfo=.false.) if (ec_mpirank()==0) call print_help() if (luse_mpi) call mpl_end(ldmeminfo=.false.) stop ! Parse verbosity argument case('-v') verbosity = 1 ! Parse number of iterations argument case('-n', '--niter') iters = get_int_value('-n', iarg) if (iters < 1) then call parsing_failed("Invalid argument for -n: must be > 0") end if ! Parse spectral truncation argument case('--nlon'); nlon = get_int_value('--nlon', iarg) case('--nlat'); nlat = get_int_value('--nlat', iarg) case('--nsmax'); nsmax = get_int_value('--nsmax', iarg) case('--nmsmax'); nmsmax = get_int_value('--nmsmax', iarg) case('-f', '--nfld'); nfld = get_int_value('-f', iarg) case('-l', '--nlev'); nlev = get_int_value('-l', iarg) case('--vordiv'); lvordiv = .True. case('--scders'); lscders = .True. case('--uvders'); luvders = .True. case('--nproma'); nproma = get_int_value('--nproma', iarg) case('--dump-values'); ldump_values = .true. case('--dump-checksums') ldump_checksums = .true. cchecksums_path = get_str_value('--dump-checksums', iarg) case('--norms'); lprint_norms = .true. case('--meminfo'); lmeminfo = .true. case('--nprgpns'); nprgpns = get_int_value('--nprgpns', iarg) case('--nprgpew'); nprgpew = get_int_value('--nprgpew', iarg) case('--nprtrv'); nprtrv = get_int_value('--nprtrv', iarg) case('--nprtrw'); nprtrw = get_int_value('--nprtrw', iarg) case('-c', '--check'); ncheck = get_int_value('-c', iarg) case default call parsing_failed("Unrecognised argument: " // trim(carg)) end select iarg = iarg + 1 end do if (.not. lvordiv) then luvders = .false. endif end subroutine get_command_line_arguments !=================================================================================================== subroutine str2int(str, int, stat) character(len=*), intent(in) :: str integer, intent(out) :: int integer, intent(out) :: stat read(str, *, iostat=stat) int end subroutine str2int !=================================================================================================== subroutine sort(a, n) real(kind=jprd), intent(inout) :: a(n) integer(kind=jpim), intent(in) :: n real(kind=jprd) :: x integer :: i, j do i = 2, n x = a(i) j = i - 1 do while (j >= 1) if (a(j) <= x) exit a(j + 1) = a(j) j = j - 1 end do a(j + 1) = x end do end subroutine sort !=================================================================================================== subroutine print_help(unit) integer, optional :: unit integer :: nout if (present(unit)) then nout = unit else nout = 6 endif write(nout, "(a)") "" if (jprb == jprd) then write(nout, "(a)") "NAME ectrans-lam-benchmark-dp" else write(nout, "(a)") "NAME ectrans-lam-benchmark-sp" end if write(nout, "(a)") "" write(nout, "(a)") "DESCRIPTION" write(nout, "(a)") " This program tests ecTrans-lam by transforming fields back and forth& & between spectral " if (jprb == jprd) then write(nout, "(a)") " space and grid-point space (double-precision version)" else write(nout, "(a)") " space and grid-point space (single-precision version)" end if write(nout, "(a)") "" write(nout, "(a)") "USAGE" if (jprb == jprd) then write(nout, "(a)") " ectrans-lam-benchmark-dp [options]" else write(nout, "(a)") " ectrans-lam-benchmark-sp [options]" end if write(nout, "(a)") "" write(nout, "(a)") "OPTIONS" write(nout, "(a)") " -h, --help Print this message" write(nout, "(a)") " -v Run with verbose output" write(nout, "(a)") " --nlon NLON Number of gridpoints in zonal direction (default = 128)" write(nout, "(a)") " --nlat NLAT Number of gridpoints in meridional direction (default = 128)" write(nout, "(a)") " --nsmax NSMAX Spectral truncation in meridional direction (default = NLAT/2-1)" write(nout, "(a)") " --nmsmax NMSMAX Spectral truncation in zonal direction (default = NLON/2-1)" write(nout, "(a)") " -n, --niter NITER Run for this many inverse/direct transform& & iterations (default = 10)" write(nout, "(a)") " -f, --nfld NFLD Number of scalar fields (default = 1)" write(nout, "(a)") " -l, --nlev NLEV Number of vertical levels (default = 1)" write(nout, "(a)") " --vordiv Also transform vorticity-divergence to wind" write(nout, "(a)") " --scders Compute scalar derivatives (default off)" write(nout, "(a)") " --uvders Compute uv East-West derivatives (default off). Only& & when also --vordiv is given" write(nout, "(a)") " --nproma NPROMA Run with NPROMA (default no blocking: NPROMA=ngptot)" write(nout, "(a)") " --norms Calculate and print spectral norms of transformed& & fields" write(nout, "(a)") " The computation of spectral norms will skew overall& & timings" write(nout, "(a)") " --meminfo Show diagnostic information from FIAT's ec_meminfo& & subroutine on memory usage, thread-binding etc." write(nout, "(a)") " --nprgpew Size of East-West set in gridpoint decomposition" write(nout, "(a)") " --nprgpns Size of North-South set in gridpoint decomposition" write(nout, "(a)") " --nprtrv Size of Vertical set in spectral decomposition" write(nout, "(a)") " --nprtrw Size of Wave set in spectral decomposition" write(nout, "(a)") " -c, --check VALUE The multiplier of the machine epsilon used as a& & tolerance for correctness checking" write(nout, "(a)") "" write(nout, "(a)") "DEBUGGING" write(nout, "(a)") " --dump-values Output gridpoint fields in unformatted binary file" write(nout, "(a)") "" end subroutine print_help !=================================================================================================== subroutine initialize_spectral_arrays(nsmax, nmsmax, zsp, sp3d) integer, intent(in) :: nsmax ! Spectral truncation in meridional direction integer, intent(in) :: nmsmax ! Spectral truncation in zonal direction real(kind=jprb), intent(inout) :: zsp(:,:) ! Surface pressure real(kind=jprb), intent(inout) :: sp3d(:,:,:) ! 3D fields integer(kind=jpim) :: nflevl integer(kind=jpim) :: nfield integer :: i, j nflevl = size(sp3d, 1) nfield = size(sp3d, 3) ! First initialize surface pressure call initialize_2d_spectral_field(nsmax, nmsmax, zsp(1,:)) ! Then initialize all of the 3D fields do i = 1, nflevl do j = 1, nfield call initialize_2d_spectral_field(nsmax, nmsmax, sp3d(i,:,j)) end do end do end subroutine initialize_spectral_arrays !=================================================================================================== subroutine initialize_2d_spectral_field(nsmax, nmsmax, field) integer, intent(in) :: nsmax ! Spectral truncation in meridional direction integer, intent(in) :: nmsmax ! Spectral truncation in zonal direction real(kind=jprb), intent(inout) :: field(:) ! Field to initialize integer :: ispec, kspec2 integer, allocatable :: my_km(:), my_kn(:) ! Choose a harmonic to initialize arrays integer :: m_num ! Zonal wavenumber integer :: n_num ! Meridional wavenumber ! Type of initialization: (single) 'harmonic' or (random) 'spectrum' character(len=32), parameter :: init_type='harmonic' ! Default harmonic m_num = 1 n_num = 0 ! First initialise all spectral coefficients to zero field(:) = 0.0 ! make sure wavenumbers are within truncation if ( m_num>nmsmax .or. n_num > nsmax .or. & & ( nsmax>0 .and. nmsmax>0 .and. ( (m_num/real(nmsmax))**2+(n_num/real(nsmax))**2 ) > 1.) ) then write (nerr,*) write (nerr,*) 'WARNING: INITIAL WAVENUMBERS OUTSIDE OF TRUNCATION! ' write (nerr,*) ' m_num = ',m_num,'; nmsmax = ',nmsmax,'; n_num = ',n_num,'; nsmax = ',nsmax,& & '; ellips check: ',(m_num/real(nmsmax))**2+(n_num/real(nsmax))**2 write (nerr,*) ' using (kx=',NMSMAX/2,', ky=', NSMAX/2,') instead' write (nerr,*) m_num=nmsmax/2 n_num=nsmax/2 endif ! Get wavenumbers this rank is responsible for call etrans_inq(kspec2=kspec2) allocate(my_kn(kspec2),my_km(kspec2)) call etrans_inq(knvalue=my_kn,kmvalue=my_km) ! If rank is responsible for the chosen zonal wavenumber... if ( init_type == 'harmonic' ) then do ispec=1,nspec2,4 if ( my_kn(ispec)== n_num .and. my_km(ispec) == m_num ) then field(ispec)=1.0 ! cos*cos !field(ispec+1)=1.0 ! cos*sin !field(ispec+2)=1.0 ! sin*cos !field(ispec+3)=1.0 ! sin*sin end if enddo endif ! random power spectrum if ( init_type == 'spectrum' ) then call random_number(field) field=2*field-1. ! center around zero ! set some components to zero because they are unphysical do ispec=1,nspec2,4 if ( my_kn(ispec)== 0 .and. my_km(ispec) == 0 ) field(ispec:ispec+3)=0. ! remove mean value for vorticity and divergence if ( my_kn(ispec)== 0 ) field(ispec+1:ispec+3:2)=0. ! remove sine component on zero meridional wavenumber !if ( my_kn(ispec)== nsmax ) field(ispec+1:ispec+3:2)=0. ! remove sine component on last meridional wavenumber -- must only be zero when nsmax==nlat/2 if ( my_km(ispec)== 0 ) field(ispec+2:ispec+3)=0. ! remove sine component on zero zonal wavenumber !if ( my_km(ispec)== nmsmax ) field(ispec+2:ispec+3)=0. ! remove sine component on last meridional wavenumber -- must only be zero when nmsmax==nlon/2 enddo ! scale according to wavenumber**2 do ispec=1,nspec2 field(ispec)=field(ispec)/(0.01+(my_kn(ispec)/real(nsmax))**2+(my_km(ispec)/real(nmsmax))**2) enddo endif deallocate(my_kn,my_km) end subroutine initialize_2d_spectral_field !=================================================================================================== subroutine dump_gridpoint_field(jstep, myproc, nlat, nproma, ngpblks, fld, fldchar, noutdump) ! Dump a 2d gridpoint field to screen or a binary file. integer(kind=jpim), intent(in) :: jstep ! Time step, used for naming file integer(kind=jpim), intent(in) :: myproc ! MPI rank, used for naming file integer(kind=jpim), intent(in) :: nlat ! Number of latitudes integer(kind=jpim), intent(in) :: nproma ! Size of nproma integer(kind=jpim), intent(in) :: ngpblks ! Number of nproma blocks real(kind=jprb) , intent(in) :: fld(nproma,1,ngpblks) ! 2D field character , intent(in) :: fldchar ! Single character field identifier integer(kind=jpim), intent(in) :: noutdump ! Unit number for output file integer(kind=jpim) :: kgptotg ! global number of gridpoints real(kind=jprb), allocatable :: fldg(:,:) ! global field integer(kind=jpim), parameter :: kfgathg=1 ! number of fields to gather integer(kind=jpim), parameter :: kto(1)=(/1/) ! processor where to gather character(len=14) :: filename character(len=13) :: frmt #include "etrans_inq.h" #include "egath_grid.h" filename = "x.xxx.xxx.grid" frmt = '(4X,xxxxF8.2)' call etrans_inq(kgptotg=kgptotg) if ( myproc == 1 ) allocate(fldg(kgptotg,1)) call egath_grid(pgpg=fldg,kproma=nproma,kfgathg=kfgathg,kto=kto,pgp=fld) if ( myproc == 1 ) then ! write to file write(filename(1:1),'(a1)') fldchar write(filename(3:5),'(i3.3)') jstep #ifdef ACCGPU write(filename(7:9),'(a3)') 'gpu' #else write(filename(7:9),'(a3)') 'cpu' #endif open(noutdump, file=filename, form="unformatted", access="stream") write(noutdump) kgptotg/nlat,nlat ! dimensions write(noutdump) fldg ! data close(noutdump) ! write to screen write(frmt(5:8),'(i4.4)') kgptotg/nlat write (*,*) fldchar,' at iteration ',jstep,':' write (*,frmt) fldg call flush(6) deallocate(fldg) endif end subroutine dump_gridpoint_field !=================================================================================================== subroutine dump_spectral_field(jstep, myproc, nspec2, nsmax, nmsmax, fld, kvset, fldchar, noutdump) ! Dump a 2d spectral field to screen or a binary file. integer(kind=jpim), intent(in) :: jstep ! Time step, used for naming file integer(kind=jpim), intent(in) :: myproc ! MPI rank, used for naming file integer(kind=jpim), intent(in) :: nspec2 ! Size of nspec2 (number of waves on this proc in M-space) integer(kind=jpim), intent(in) :: nsmax integer(kind=jpim), intent(in) :: nmsmax real(kind=jprb) , intent(in) :: fld(1,nspec2) ! 2D field integer(kind=jpim), intent(in) :: kvset(1) ! B-set on which the field resides character , intent(in) :: fldchar ! Single character field identifier integer(kind=jpim), intent(in) :: noutdump ! Unit number for output file integer(kind=jpim) :: nspec2g ! global number of gridpoints real(kind=jprb), allocatable :: fldg(:,:) ! global field (nspec2g) integer(kind=jpim), parameter :: kfgathg=1 ! number of fields to gather integer(kind=jpim), parameter :: kto(1)=(/1/) ! processor where to gather character(len=14) :: filename character(len=13) :: frmt ! for printing to screen integer(kind=jpim) :: knse(0:nmsmax),kmse(0:nsmax) ! elliptic truncation real(kind=jprb) :: fld2g(0:2*nmsmax+1,0:2*nsmax+1) ! 2D representation of spectral field integer(kind=jpim) :: jj, jms, jns #include "etrans_inq.h" #include "egath_spec.h" filename = "x.xxx.xxx.spec" frmt = '(4X,xxxxF8.2)' if ( myproc == 1 ) then call etrans_inq(kspec2g=nspec2g) allocate(fldg(1,nspec2g)) call ellips(nsmax,nmsmax,knse,kmse) endif call egath_spec(pspecg=fldg,kfgathg=kfgathg,kto=kto,kvset=kvset,pspec=fld) if ( myproc == 1 ) then fld2g=0. jj=1 do jms=0,nmsmax do jns=0,knse(jms) fld2g(2*jms+0,2*jns+0)=fldg(1,jj) fld2g(2*jms+0,2*jns+1)=fldg(1,jj+1) fld2g(2*jms+1,2*jns+0)=fldg(1,jj+2) fld2g(2*jms+1,2*jns+1)=fldg(1,jj+3) jj=jj+4 enddo enddo ! write to binary file write(filename(1:1),'(a1)') fldchar write(filename(3:5),'(i3.3)') jstep #ifdef ACCGPU write(filename(7:9),'(a3)') 'gpu' #else write(filename(7:9),'(a3)') 'cpu' #endif open(noutdump, file=filename, form="unformatted", access="stream") write(noutdump) 2*nmsmax+2,2*nsmax+2 ! dimensions write(noutdump) fld2g ! data close(noutdump) ! write to screen write(frmt(5:8),'(i4.4)') 2*(nmsmax+1) write (*,*) fldchar,' at iteration ',jstep,':' write (*,frmt) fld2g call flush(6) deallocate(fldg) endif end subroutine dump_spectral_field !=================================================================================================== subroutine dump_checksums(filename, noutdump, & & jstep, myproc, nproma, ngptotg, nspec2g, & & ivset, ivsetsc, & & zgpuv, zgp3a, zgp2, sp3d, zspc2) character(len=*), intent(in) :: filename ! filename integer(kind=jpim), intent(in) :: noutdump ! unit number for output file integer(kind=jpim), intent(in) :: jstep ! time step integer(kind=jpim), intent(in) :: myproc ! mpi rank integer(kind=jpim), intent(in) :: nproma ! size of nproma integer(kind=jpim), intent(in) :: ngptotg integer(kind=jpim), intent(in) :: nspec2g integer(kind=jpim), intent(in) :: ivset (:) integer(kind=jpim), intent(in) :: ivsetsc(1) real(kind=jprb), intent(in), optional :: zgpuv (:,:,:,:) real(kind=jprb), intent(in), optional :: zgp3a (:,:,:,:) real(kind=jprb), intent(in), optional :: zgp2 (:,:,:) real(kind=jprb), intent(in), optional :: sp3d (:,:,:) real(kind=jprb), intent(in), optional :: zspc2 (:,:) integer(kind=jpib) :: icrc integer(kind=jpim) :: jlev, jfld, numfld real(kind=jprb), allocatable :: gfld(:,:) real(kind=jprb), allocatable :: gspfld(:,:) logical :: exist = .false. if (myproc == 1) then if (jstep>1) inquire(file = filename, exist = exist) if (exist) then open(noutdump, file = filename, status="old", position="append", action="write") else open(noutdump, file = filename, action="write") endif write(noutdump,*) "====================" write(noutdump,*) "iteration", jstep write(noutdump,*) "====================" if (present(zgpuv) .or. present(zgp3a) .or. present(zgp2)) allocate(gfld(ngptotg,1)) if (present(sp3d) .or. present(zspc2)) allocate(gspfld(max(size(ivset), 1), nspec2g)) endif if (present(zgpuv)) then icrc = 0 do jfld = 1, size (zgpuv, 3) do jlev = 1, size (zgpuv, 2) call egath_grid(pgpg=gfld,kproma=nproma,kfgathg=1,kto=(/1/),kresol=1,pgp=zgpuv(:,jlev:jlev,jfld, :)) if (myproc == 1) then call crc64 (gfld (:, :), int (size (gfld (:, :)) * kind (gfld), 8), icrc) write (noutdump, '(a," (",i0,", ",i0,") = ",z16.16)') "zgpuv", jlev, jfld, icrc endif enddo enddo endif if (present(zgp3a)) then icrc = 0 do jfld = 1, size (zgp3a, 3) do jlev = 1, size (zgp3a, 2) call egath_grid(pgpg=gfld,kproma=nproma,kfgathg=1,kto=(/1/),kresol=1,pgp=zgp3a(:,jlev:jlev,jfld, :)) if (myproc == 1) then call crc64 (gfld (:, :), int (size (gfld (:, :)) * kind (gfld), 8), icrc) write (noutdump, '(a," (",i0,", ",i0,") = ",z16.16)') "zgp3a", jlev, jfld, icrc endif enddo enddo endif if (present(zgp2)) then icrc = 0 do jfld = 1, size (zgp2, 2) call egath_grid(pgpg=gfld,kproma=nproma,kfgathg=1,kto=(/1/),kresol=1,pgp=zgp2(:,jfld:jfld,:)) if (myproc == 1) then call crc64 (gfld (:, :), int (size (gfld (:, :)) * kind (gfld), 8), icrc) write (noutdump, '(a," (",i0,") = ",z16.16)') "zgp2", jfld, icrc endif enddo endif if (present(sp3d)) then numfld = size(ivset) do jfld = 1, size (sp3d, 3) if (myproc == 1) then call egath_spec(pspecg=gspfld(1:numfld,:), kfgathg=numfld, kto=[(1, i = 1, numfld)], & & kvset=ivset, pspec=sp3d(:,:,jfld)) icrc = 0 call crc64(gspfld(1:numfld,:), int(size(gspfld(1:numfld,:)) * kind(gspfld), 8), icrc) write(noutdump, '(a,"(",i0,") = ",z16.16)') "sp3d", jfld, icrc else call egath_spec(kfgathg=numfld, kto=[(1, i = 1, numfld)], kvset=ivset, pspec=sp3d(:,:,jfld)) endif enddo endif if (present(zspc2)) then if (myproc == 1) then call egath_spec(pspecg=gspfld(1:1,:), kfgathg=1, kto=[1], kvset=ivsetsc, pspec=zspc2) icrc = 0 call crc64(gspfld(1,:), int(size(gspfld(1,:)) * kind(gspfld), 8), icrc) write (noutdump, '(a," = ",z16.16)') "zspc2", icrc else call egath_spec(kfgathg=1, kto=[1], kvset=ivsetsc, pspec=zspc2) endif endif if (myproc == 1) then close(noutdump) if (allocated(gfld)) deallocate(gfld) if (allocated(gspfld)) deallocate(gspfld) endif end subroutine dump_checksums !=================================================================================================== function detect_mpirun() result(lmpi_required) logical :: lmpi_required integer :: ilen integer, parameter :: nvars = 5 character(len=32), dimension(nvars) :: cmpirun_detect character(len=4) :: clenv_dr_hook_assert_mpi_initialized integer :: ivar ! Environment variables that are set when mpirun, srun, aprun, ... are used cmpirun_detect(1) = 'OMPI_COMM_WORLD_SIZE' ! openmpi cmpirun_detect(2) = 'ALPS_APP_PE' ! cray pe cmpirun_detect(3) = 'PMI_SIZE' ! intel cmpirun_detect(4) = 'SLURM_NTASKS' ! slurm cmpirun_detect(5) = 'ECTRANS_USE_MPI' ! forced lmpi_required = .false. do ivar = 1, nvars call get_environment_variable(name=trim(cmpirun_detect(ivar)), length=ilen) if (ilen > 0) then lmpi_required = .true. exit ! break endif enddo end function !=================================================================================================== ! Assign GSTATS labels to the main regions of ecTrans subroutine gstats_labels call gstats_label(0, ' ', 'PROGRAM - Total') call gstats_label(1, ' ', 'SETUP_TRANS0 - Setup ecTrans') call gstats_label(2, ' ', 'SETUP_TRANS - Setup ecTrans handle') call gstats_label(3, ' ', 'TIME STEP - Time step') call gstats_label(4, ' ', 'INV_TRANS - Inverse transform') call gstats_label(5, ' ', 'DIR_TRANS - Direct transform') call gstats_label(6, ' ', 'NORMS - Norm comp. (optional)') call gstats_label(102, ' ', 'LTINV_CTL - Inv. Legendre transform') call gstats_label(103, ' ', 'LTDIR_CTL - Dir. Legendre transform') call gstats_label(106, ' ', 'FTDIR_CTL - Dir. Fourier transform') call gstats_label(107, ' ', 'FTINV_CTL - Inv. Fourier transform') call gstats_label(140, ' ', 'SULEG - Comp. of Leg. poly.') call gstats_label(152, ' ', 'LTINV_CTL - M to L transposition') call gstats_label(153, ' ', 'LTDIR_CTL - L to M transposition') call gstats_label(157, ' ', 'FTINV_CTL - L to G transposition') call gstats_label(158, ' ', 'FTDIR_CTL - G to L transposition') call gstats_label(400, ' ', 'GSTATS - GSTATS itself') end subroutine gstats_labels end program ectrans_lam_benchmark !=================================================================================================== ectrans-1.8.0/src/programs/ectrans.in0000775000175000017500000000523715174631767020006 0ustar alastairalastair#!/usr/bin/env bash # (C) Copyright 2020- ECMWF. # # 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. ECTRANS_VERSION_STR="@ectrans_VERSION_STR@" ECTRANS_VERSION="@ectrans_VERSION@" ECTRANS_GIT_SHA1="@ectrans_GIT_SHA1@" ################################################################# # Commands ################################################################# usage() { echo "Usage: ectrans [--version] [--info] [--git]" exit $1 } version() { echo "${ECTRANS_VERSION_STR}" } append_git() { if (( $# > b )); then git="$@" echo ", git-sha1 ${git::${#git}-33}" fi } info() { echo "ectrans version (${ECTRANS_VERSION_STR})$(append_git ${ECTRANS_GIT_SHA1})" echo "" echo "Build:" echo " build type : @CMAKE_BUILD_TYPE@" echo " timestamp : @EC_BUILD_TIMESTAMP@" echo " op. system : @CMAKE_SYSTEM@ (@EC_OS_NAME@.@EC_OS_BITS@)" echo " processor : @CMAKE_SYSTEM_PROCESSOR@" echo " c compiler : @CMAKE_C_COMPILER_ID@ @CMAKE_C_COMPILER_VERSION@" echo " flags : @EC_C_FLAGS@" echo " fortran compiler: @CMAKE_Fortran_COMPILER_ID@ @CMAKE_Fortran_COMPILER_VERSION@" echo " flags : @EC_Fortran_FLAGS@" echo "" echo "Features:" echo " MPI : @HAVE_MPI@" echo " OMP : @ectrans_HAVE_OMP@" echo " MKL : @ectrans_HAVE_MKL@" echo " FFTW : @ectrans_HAVE_FFTW@" echo " TRANSI : @ectrans_HAVE_TRANSI@" echo "" echo "Dependencies: " echo " fiat version (@fiat_VERSION_STR@)$(append_git @fiat_GIT_SHA1@)" } gitsha1() { echo "${ECTRANS_GIT_SHA1}" } ################################################################# # Parse command-line ################################################################# if test $# -eq 0; then usage 1 fi while test $# -gt 0; do # Split --option=value in $opt="--option" and $val="value" opt="" val="" case "$1" in --*=*) opt=`echo "$1" | sed 's/=.*//'` val=`echo "$1" | sed 's/--[_a-zA-Z0-9]*=//'` ;; --*) opt=$1 ;; *) break ;; esac # Parse options case "$opt" in --version) version ;; --git) gitsha1 ;; --info) info ;; --) shift break ;; *) echo "unknown option: $opt" usage 1 ;; esac shift done ectrans-1.8.0/src/programs/CMakeLists.txt0000664000175000017500000001154015174631767020546 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. #foreach( program ectrans-benchmark ectrans-benchmark-ifs ) foreach( program ectrans-benchmark ) list( APPEND util_src util/ectrans_memory.F90 util/ectrans_memory.c ) if ( HAVE_CPU ) foreach( prec dp sp ) if( HAVE_${prec} ) ecbuild_add_executable( TARGET ${program}-cpu-${prec} SOURCES ${program}.F90 ${util_src} LINKER_LANGUAGE Fortran LIBS fiat parkind_${prec} trans_${prec} DEFINITIONS VERSION="cpu" ) ecbuild_target_fortran_module_directory(TARGET ${program}-cpu-${prec} MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/module/${program}-cpu-${prec} ) endif() endforeach( prec) endif() if( HAVE_GPU ) list( APPEND util_PRIVATE_DEFINITIONS $<${HAVE_CUDA}:CUDA> $<${HAVE_HIP}:HIP> ) list( APPEND util_PRIVATE_LIBRARIES $<${HAVE_CUDA}:CUDA::cudart> $<${HAVE_HIP}:hip::host> ) foreach( prec dp sp ) if( HAVE_${prec} ) ecbuild_add_executable( TARGET ${program}-gpu-${prec} SOURCES ${program}.F90 ${util_src} LINKER_LANGUAGE Fortran LIBS fiat parkind_${prec} trans_gpu_${prec} $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> $<${HAVE_OMP}:OpenMP::OpenMP_Fortran> ${util_PRIVATE_LIBRARIES} DEFINITIONS VERSION="gpu" ${util_PRIVATE_DEFINITIONS} ) ecbuild_target_fortran_module_directory(TARGET ${program}-gpu-${prec} MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/module/${program}-gpu-${prec} ) endif() endforeach( prec ) endif( HAVE_GPU ) endforeach( program ) if( HAVE_ETRANS ) set(program ectrans-lam-benchmark) foreach( prec sp dp ) if( HAVE_${prec} ) ecbuild_add_executable( TARGET ${program}-cpu-${prec} SOURCES ${program}.F90 LINKER_LANGUAGE Fortran LIBS fiat parkind_${prec} trans_${prec} etrans_${prec} $<${HAVE_OMP}:OpenMP::OpenMP_Fortran> ) endif() if( HAVE_ETRANS_GPU ) list( APPEND util_PRIVATE_DEFINITIONS $<${HAVE_CUDA}:CUDA> $<${HAVE_HIP}:HIP> ) list( APPEND util_PRIVATE_LIBRARIES $<${HAVE_CUDA}:CUDA::cudart> $<${HAVE_HIP}:hip::host> ) if( HAVE_${prec} ) ecbuild_add_executable( TARGET ${program}-gpu-${prec} SOURCES ${program}.F90 LINKER_LANGUAGE Fortran LIBS fiat parkind_${prec} trans_gpu_${prec} etrans_gpu_${prec} $<${HAVE_ACC}:OpenACC::OpenACC_Fortran> $<${HAVE_OMP}:OpenMP::OpenMP_Fortran> ${util_PRIVATE_LIBRARIES} DEFINITIONS VERSION="gpu" ${util_PRIVATE_DEFINITIONS} ) ecbuild_target_fortran_module_directory(TARGET ${program}-gpu-${prec} MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/module/${program}-gpu-${prec} ) endif() endif( ) endforeach( prec ) endif() # ectrans information tool get_property( langs GLOBAL PROPERTY ENABLED_LANGUAGES ) foreach( lang ${langs} ) set( EC_${lang}_FLAGS "${CMAKE_${lang}_FLAGS} ${CMAKE_${lang}_FLAGS_${CMAKE_BUILD_TYPE_CAPS}}" ) endforeach() configure_file( ectrans.in ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/ectrans @ONLY ) file(COPY ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/ectrans DESTINATION ${CMAKE_BINARY_DIR}/bin FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE) install( FILES ${CMAKE_BINARY_DIR}/bin/ectrans DESTINATION ${INSTALL_BIN_DIR} PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE ) ectrans-1.8.0/src/ectrans4py/0000775000175000017500000000000015174631767016247 5ustar alastairalastairectrans-1.8.0/src/ectrans4py/ectrans_version.F900000664000175000017500000000130215174631767021727 0ustar alastairalastairSUBROUTINE ECTRANS_VERSION(CD_VERSION_STRING) ! ** PURPOSE ! Return the version string of ecTrans ! ! ** DUMMY ARGUMENTS ! CD_VERSION_STRING: version string ! ! ** AUTHOR ! 18 March 2025, S. Hatfield ! ! I. Dummy arguments declaration USE ECTRANS_VERSION_MOD, ONLY: ECTRANS_VERSION_STR USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_CHAR IMPLICIT NONE CHARACTER(KIND=C_CHAR), DIMENSION(14), INTENT(OUT) :: CD_VERSION_STRING ! ! II. Local variables INTEGER :: JI CHARACTER(LEN=SIZE(CD_VERSION_STRING)) :: C_VERSION_STRING ! ! III. Get version C_VERSION_STRING = ECTRANS_VERSION_STR() DO JI=1, SIZE(CD_VERSION_STRING) CD_VERSION_STRING(JI)=C_VERSION_STRING(JI:JI) ENDDO ! END SUBROUTINE ECTRANS_VERSION ectrans-1.8.0/src/ectrans4py/__init__.py0000664000175000017500000003211015174631767020355 0ustar alastairalastair#!/usr/bin/env python3 # -*- coding: utf-8 -*- """ ectrans4py: A Python interface to spectral transforms from ecTrans, using cTypesForFortran for the Fortran/Python binding. """ from __future__ import print_function, absolute_import, unicode_literals, division import os import resource import numpy as np import ctypesForFortran from ctypesForFortran import addReturnCode, treatReturnCode, IN, OUT, array2string import platform # Shared objects library ######################## system = platform.system() if system == "Linux": platform_ext = "so" elif system == "Darwin": platform_ext = "dylib" else: raise NotImplementedError("ectrans4py does not support Windows") lib_basename = f"libectrans4py_dp.{platform_ext}" # local name of library in the directory LD_LIBRARY_PATH = [p for p in os.environ.get('LD_LIBRARY_PATH', '').split(':') if p != ''] lpath = LD_LIBRARY_PATH + [ os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib'), os.path.join(os.path.dirname(os.path.realpath(__file__)), 'lib64'), ] for d in lpath: shared_objects_library = os.path.join(d, lib_basename) if os.path.exists(shared_objects_library): break else: shared_objects_library = None if shared_objects_library is None: msg = ' '.join(["'{}' was not found in any of potential locations: {}.", "You can specify a different location using env var LD_LIBRARY_PATH"]) msg = msg.format(lib_basename, str(lpath)) raise FileNotFoundError(msg) ctypesFF, handle = ctypesForFortran.ctypesForFortranFactory(shared_objects_library) # Initialization ################ def init_env(omp_num_threads=None, no_mpi=True, unlimited_stack=True, ): """ Set adequate environment for the inner libraries. :param int omp_num_threads: sets OMP_NUM_THREADS :param bool no_mpi: environment variable DR_HOOK_NOT_MPI set to 1 :param unlimited_stack: equivalent to 'ulimit -s unlimited' """ # because arpifs library is compiled with MPI & openMP if omp_num_threads is not None: os.environ['OMP_NUM_THREADS'] = str(omp_num_threads) if no_mpi: os.environ['DR_HOOK_NOT_MPI'] = '1' if unlimited_stack: resource.setrlimit(resource.RLIMIT_STACK, (resource.RLIM_INFINITY, resource.RLIM_INFINITY)) # Transforms interfaces ####################### @array2string(0) @ctypesFF() def ectrans_version(): """ Return the version string of ecTrans. Returns:\n 1) CD_VERSION_STRING: version string of ecTrans (always 14 elements so must be trimmed) """ return ([], [(str, (1, 14), OUT)], None) @treatReturnCode @ctypesFF() @addReturnCode def get_legendre_assets(KSIZEJ, KTRUNC, KSLOEN, KSPOLEGL, KLOEN, KNUMMAXRESOL): """ Fetch arrays relevant for performing the Legendre transform. KNMENG and PGW are specified across the full globe, pole to pole. PRPNM is specified across the Northern hemisphere only. Args:\n 1) KSIZEJ: number of latitudes in grid-point space 2) KTRUNC: truncation 3) KSLOEN: Size of KLOEN 4) KSPOLEGL: the second dimension of the array storing all of the Legendre polynomials, equal to sum([truncation + 2 - im for im in range(truncation+1)]) 5) KLOEN: number of points on each latitude row 6) KNUMMAXRESOL: maximum number of troncatures handled Returns:\n 1) KNMENG: cut-off zonal wavenumber 2) PGW: Gaussian weights 3) PRPNM: associated Legendre polynomials """ return ([KSIZEJ, KTRUNC, KSLOEN, KSPOLEGL, KLOEN, KNUMMAXRESOL], [(np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, (KSLOEN,), IN), (np.int64, None, IN), (np.int64, (KSLOEN,), OUT), (np.float64, (KSLOEN,), OUT), (np.float64, (KSLOEN//2,KSPOLEGL), OUT)], None) @treatReturnCode @ctypesFF() @addReturnCode def etrans_inq4py(KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELATX, PDELATY): """ Simplified wrapper to ETRANS_INQ. Args:\n 1,2) KSIZEI, KSIZEJ: size of grid-point field (with extension zone) 3,4) KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field 5,6) KTRUNCX, KTRUNCY: troncatures 7) KNUMMAXRESOL: maximum number of troncatures handled 8,9) PDELTAX, PDELTAY: resolution along x,y axis Returns:\n 1) KGPTOT: number of gridpoints 2) KSPEC: number of spectral coefficients """ return ([KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELATX, PDELATY], [(np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.float64, None, IN), (np.float64, None, IN), (np.int64, None, OUT), (np.int64, None, OUT)], None) @treatReturnCode @ctypesFF() @addReturnCode def trans_inq4py(KSIZEJ, KTRUNC, KSLOEN, KLOEN, KNUMMAXRESOL): """ Simplified wrapper to TRANS_INQ. Args:\n 1) KSIZEJ: number of latitudes in grid-point space 2) KTRUNC: troncature 3) KSLOEN: Size of KLOEN 4) KLOEN: number of points on each latitude row 5) KNUMMAXRESOL: maximum number of troncatures handled Returns:\n 1) KGPTOT: number of gridpoints 2) KSPEC: number of spectral coefficients 3) KNMENG: cut-off zonal wavenumber """ return ([KSIZEJ, KTRUNC, KSLOEN, KLOEN, KNUMMAXRESOL], [(np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, (KSLOEN,), IN), (np.int64, None, IN), (np.int64, None, OUT), (np.int64, None, OUT), (np.int64, (KSLOEN,), OUT)], None) @treatReturnCode @ctypesFF() @addReturnCode def sp2gp_lam4py(KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, KTRUNCX, KTRUNCY, KNUMMAXRESOL, KSIZE, LGRADIENT, LREORDER, PDELTAX, PDELTAY, PSPEC): """ Transform spectral coefficients into grid-point values. Args:\n 1,2) KSIZEI, KSIZEJ: size of grid-point field (with extension zone) 3,4) KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field 5,6) KTRUNCX, KTRUNCY: troncatures 7) KNUMMAXRESOL: maximum number of troncatures handled 8) KSIZE: size of PSPEC 9) LGRADIENT: gradient computation 10) LREORDER: reorder spectral coefficients or not 11,12) PDELTAX,PDELTAY: resolution along x,y axis 13) PSPEC: spectral coefficient array Returns:\n 1) PGPT: grid-point field 2) PGPTM: N-S derivative if LGRADIENT 3) PGPTL: E-W derivative if LGRADIENT """ return ([KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, KTRUNCX, KTRUNCY, KNUMMAXRESOL, KSIZE, LGRADIENT, LREORDER, PDELTAX, PDELTAY, PSPEC], [(np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (bool, None, IN), (bool, None, IN), (np.float64, None, IN), (np.float64, None, IN), (np.float64, (KSIZE,), IN), (np.float64, (KSIZEI * KSIZEJ,), OUT), (np.float64, (KSIZEI * KSIZEJ,), OUT), (np.float64, (KSIZEI * KSIZEJ,), OUT)], None) @treatReturnCode @ctypesFF() @addReturnCode def gp2sp_lam4py(KSIZE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELTAX, PDELTAY, LREORDER, PGPT): """ Transform grid point values into spectral coefficients. Args:\n 1) KSIZE: size of spectral field 2,3) KSIZEI, KSIZEJ: size of grid-point field (with extension zone) 4,5) KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field 6,7) KTRUNCX, KTRUNCY: troncatures 8) KNUMMAXRESOL: maximum number of troncatures handled 9,10) PDELTAX, PDELTAY: resolution along x,y axis 11) LREORDER: reorder spectral coefficients or not 12) PGPT: grid-point field Returns:\n 1) PSPEC: spectral coefficient array """ return ([KSIZE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELTAX, PDELTAY, LREORDER, PGPT], [(np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.float64, None, IN), (np.float64, None, IN), (bool, None, IN), (np.float64, (KSIZEI * KSIZEJ,), IN), (np.float64, (KSIZE,), OUT)], None) @treatReturnCode @ctypesFF() @addReturnCode def sp2gp_gauss4py(KSIZEJ, KTRUNC, KNUMMAXRESOL, KGPTOT, KSLOEN, KLOEN, KSIZE, LGRADIENT, LREORDER, PSPEC): """ Transform spectral coefficients into grid-point values. Args:\n 1) KSIZEJ: Number of latitudes 2) KTRUNC: troncature 3) KNUMMAXRESOL: maximum number of troncatures handled 4) KGPTOT: number of grid-points 5) KSLOEN: Size of KLOEN 6) KLOEN: 7) KSIZE: Size of PSPEC 8) LGRADIENT: compute derivatives 9) LREORDER: reorder spectral coefficients or not 10) PSPEC: spectral coefficient array Returns:\n 1) PGPT: grid-point field 2) PGPTM: N-S derivative if LGRADIENT 3) PGPTL: E-W derivative if LGRADIENT """ return ([KSIZEJ, KTRUNC, KNUMMAXRESOL, KGPTOT, KSLOEN, KLOEN, KSIZE, LGRADIENT, LREORDER, PSPEC], [(np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, (KSLOEN,), IN), (np.int64, None, IN), (bool, None, IN), (bool, None, IN), (np.float64, (KSIZE,), IN), (np.float64, (KGPTOT,), OUT), (np.float64, (KGPTOT,), OUT), (np.float64, (KGPTOT,), OUT)], None) @treatReturnCode @ctypesFF() @addReturnCode def gp2sp_gauss4py(KSPEC, KSIZEJ, KTRUNC, KNUMMAXRESOL, KSLOEN, KLOEN, KSIZE, LREORDER, PGPT): """ Transform grid-point values into spectral coefficients. Args:\n 1) KSPEC: size of spectral coefficients array 2) KSIZEJ: Number of latitudes 3) KTRUNC: troncature 4) KNUMMAXRESOL: maximum number of troncatures handled 5) KSLOEN: Size of KLOEN 6) KLOEN 7) KSIZE: Size of PGPT 8) LREORDER: reorder spectral coefficients or not 9) PGPT: grid-point field Returns:\n 1) PSPEC: spectral coefficient array """ return ([KSPEC, KSIZEJ, KTRUNC, KNUMMAXRESOL, KSLOEN, KLOEN, KSIZE, LREORDER, PGPT], [(np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, None, IN), (np.int64, (KSLOEN,), IN), (np.int64, None, IN), (bool, None, IN), (np.float64, (KSIZE,), IN), (np.float64, (KSPEC,), OUT)], None) @ctypesFF() def sp2gp_fft1d4py(KSIZES, KTRUNC, PSPEC, KSIZEG): """ Transform spectral coefficients into grid-point values, for a 1D array (vertical section academic model) Args:\n 1) KSIZES size of PSPEC 2) KTRUNC: troncature 3) PSPEC: spectral coefficient array 4) KSIZEG: size of grid-point field (with extension zone) Returns:\n 1) PGPT: grid-point field """ return ([KSIZES, KTRUNC, PSPEC, KSIZEG], [(np.int64, None, IN), (np.int64, None, IN), (np.float64, (KSIZES,), IN), (np.int64, None, IN), (np.float64, (KSIZEG,), OUT)], None) __version__ = ectrans_version().strip() ectrans-1.8.0/src/ectrans4py/trans_inq4py.F900000664000175000017500000000410415174631767021161 0ustar alastairalastairSUBROUTINE TRANS_INQ4PY(KRETURNCODE, KSIZEJ, KTRUNC, KSLOEN, KLOEN, KNUMMAXRESOL, & &KGPTOT, KSPEC, KNMENG) ! ** PURPOSE ! Simplified wrapper to TRANS_INQ ! ! ** DUMMY ARGUMENTS ! KSIZEJ: number of latitudes in grid-point space ! KTRUNC: troncature ! KSLOEN: Size of KLOEN ! KLOEN: number of points on each latitude row ! KNUMMAXRESOL: maximum number of troncatures handled ! KGPTOT: number of gridpoints ! KSPEC: number of spectral coefficients ! KNMENG: cut-off zonal wavenumber ! ! ** AUTHOR ! 9 April 2014, S. Riette ! ! ** MODIFICATIONS ! 6 Jan., S. Riette: w_spec_setup interfaced modified ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 IMPLICIT NONE INTEGER(KIND=INT64), INTENT(OUT) :: KRETURNCODE INTEGER(KIND=INT64), INTENT(IN) :: KSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KTRUNC INTEGER(KIND=INT64), INTENT(IN) :: KSLOEN INTEGER(KIND=INT64), DIMENSION(KSLOEN), INTENT(IN) :: KLOEN INTEGER(KIND=INT64), INTENT(IN) :: KNUMMAXRESOL INTEGER(KIND=INT64), INTENT(OUT) :: KGPTOT INTEGER(KIND=INT64), INTENT(OUT) :: KSPEC INTEGER(KIND=INT64), DIMENSION(KSLOEN), INTENT(OUT) :: KNMENG ! ! II. Local variables declaration INTEGER, DIMENSION(SIZE(KLOEN)) :: ILOEN INTEGER :: ISIZEI, ISIZEJ, & & IPHYSICALSIZEI, IPHYSICALSIZEJ, & & ITRUNCX, ITRUNCY, & & INUMMAXRESOL LOGICAL :: LLSTOP INTEGER :: IIDENTRESOL INTEGER :: IGPTOT, ISPEC INTEGER, DIMENSION(SIZE(KLOEN)) :: INMENG REAL(KIND=REAL64) :: ZDELTAX, ZDELTAY #include "trans_inq.h" ILOEN(:)=KLOEN(:) ISIZEI=0 ISIZEJ=KSIZEJ IPHYSICALSIZEI=0 IPHYSICALSIZEJ=0 ITRUNCX=KTRUNC ITRUNCY=0 INUMMAXRESOL=KNUMMAXRESOL ! ! III. Setup ZDELTAX=0. ZDELTAY=0. CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .FALSE., SIZE(ILOEN), & &ZDELTAX, ZDELTAY, IIDENTRESOL, LLSTOP) IF (.NOT. LLSTOP) THEN CALL TRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KNMENG=INMENG) KGPTOT=IGPTOT KSPEC=ISPEC KNMENG=INMENG ENDIF ! END SUBROUTINE TRANS_INQ4PY ectrans-1.8.0/src/ectrans4py/gp2sp_gauss4py.F900000664000175000017500000000626715174631767021434 0ustar alastairalastairSUBROUTINE GP2SP_GAUSS4PY(KRETURNCODE, KSPEC, KSIZEJ, KTRUNC, KNUMMAXRESOL, KSLOEN, KLOEN, KSIZE, LREORDER, PGPT, PSPEC) ! ** PURPOSE ! Transform spectral coefficients into grid-point values ! ! ** DUMMY ARGUMENTS ! KRETURNCODE: error code ! KSPEC: size of spectral coefficients array ! KSIZEJ: Number of latitudes ! KTRUNC: troncature ! KNUMMAXRESOL: maximum number of troncatures handled ! KSLOEN: Size ok KLOEN ! KLOEN ! KSIZE: Size of PGPT ! LREORDER: switch to reorder spectral coefficients or not ! PGPT: grid-point field ! PSPEC: spectral coefficient array ! ! ** AUTHOR ! 9 April 2014, S. Riette ! ! ** MODIFICATIONS ! 6 Jan. 2016, S. Riette: w_spec_setup interface modified ! March, 2016, A.Mary: LREORDER ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 USE PARKIND1, ONLY : JPRB USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_BOOL IMPLICIT NONE INTEGER(KIND=INT64), INTENT(OUT) :: KRETURNCODE INTEGER(KIND=INT64), INTENT(IN) :: KSPEC INTEGER(KIND=INT64), INTENT(IN) :: KSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KTRUNC INTEGER(KIND=INT64), INTENT(IN) :: KNUMMAXRESOL INTEGER(KIND=INT64), INTENT(IN) :: KSLOEN INTEGER(KIND=INT64), DIMENSION(KSLOEN), INTENT(IN) :: KLOEN INTEGER(KIND=INT64), INTENT(IN) :: KSIZE LOGICAL(KIND=C_BOOL), INTENT(IN) :: LREORDER REAL(KIND=REAL64), DIMENSION(KSIZE), INTENT(IN) :: PGPT REAL(KIND=REAL64), DIMENSION(KSPEC), INTENT(OUT) :: PSPEC ! ! II. Local variables declaration INTEGER, DIMENSION(SIZE(KLOEN)) :: ILOEN INTEGER :: ISIZEI, ISIZEJ, & & IPHYSICALSIZEI, IPHYSICALSIZEJ, & & ITRUNCX, ITRUNCY, & & INUMMAXRESOL LOGICAL :: LLSTOP INTEGER :: IIDENTRESOL INTEGER :: JI, JM, JN INTEGER, DIMENSION(0:KTRUNC) :: NASM0 REAL(KIND=JPRB), DIMENSION(1, SIZE(PGPT)) :: ZSPBUF !size over-evaluated REAL(KIND=JPRB), DIMENSION(SIZE(PGPT), 1, 1) :: ZGPBUF REAL(KIND=REAL64) :: ZDELTAX, ZDELTAY #include "trans_inq.h" #include "dir_trans.h" KRETURNCODE=0 ILOEN(:)=KLOEN(:) ISIZEI=0 ISIZEJ=KSIZEJ IPHYSICALSIZEI=0 IPHYSICALSIZEJ=0 ITRUNCX=KTRUNC ITRUNCY=0 INUMMAXRESOL=KNUMMAXRESOL ! ! III. Setup ZDELTAX=0. ZDELTAY=0. CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .FALSE., SIZE(ILOEN), & &ZDELTAX, ZDELTAY, IIDENTRESOL, LLSTOP) ! ! IV. Transformation ! IV.a Shape of coefficient array IF (.NOT. LLSTOP) THEN JI=1 DO JN=0, KTRUNC NASM0(JN)=JI JI=JI+1+JN+(JN+1) ENDDO ENDIF ! IV.b Direct transform IF (.NOT. LLSTOP) THEN ZGPBUF(:,1,1)=REAL(PGPT(:),KIND=JPRB) CALL DIR_TRANS(PSPSCALAR=ZSPBUF(:,:), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) ENDIF ! IV.c Reordering IF (LREORDER) THEN IF(.NOT. LLSTOP) THEN PSPEC(:)=0. JI=1 DO JM=0, KTRUNC DO JN=JM, KTRUNC PSPEC(NASM0(JN)+JM)=REAL(ZSPBUF(1,JI),KIND=8) JI=JI+1 IF(JM/=0) THEN PSPEC(NASM0(JN)-JM)=REAL(ZSPBUF(1,JI),KIND=8) ENDIF JI=JI+1 ENDDO ENDDO IF(JI-1/=KSPEC) THEN PRINT*, "Internal error in GP2SP_GAUSS4PY (spectral reordering)" KRETURNCODE=-999 ENDIF ENDIF ELSE PSPEC(1:KSPEC) = REAL(ZSPBUF(1,1:KSPEC),KIND=8) ENDIF END SUBROUTINE GP2SP_GAUSS4PY ectrans-1.8.0/src/ectrans4py/get_legendre_assets.F900000664000175000017500000000442115174631767022536 0ustar alastairalastairSUBROUTINE GET_LEGENDRE_ASSETS(KRETURNCODE, KSIZEJ, KTRUNC, KSLOEN, KSPOLEGL, KLOEN, KNUMMAXRESOL, & & KNMENG, PGW, PRPNM) ! ** PURPOSE ! Simplified wrapper to TRANS_INQ for obtaining arrays necessary for performing Legendre transform ! (Gaussian weights, Legendre polynomials and NMENG (cutoff zonal wavenumber for each latitude)) ! ! ** DUMMY ARGUMENTS ! KSIZEJ: number of latitudes in grid-point space ! KTRUNC: troncature ! KSLOEN: Size of KLOEN ! KSPOLEGL: Size of second dimension of Legendre polynomials ! KLOEN: number of points on each latitude row ! KNUMMAXRESOL: maximum number of troncatures handled ! KNMENG: cut-off zonal wavenumber ! PGW: Gaussian weights ! PRPNM: Legendre polynomials ! ! ** AUTHOR ! 2 July 2025, S. Hatfield ! ! I. Dummy arguments declaration IMPLICIT NONE INTEGER(KIND=8), INTENT(OUT) :: KRETURNCODE INTEGER(KIND=8), INTENT(IN) :: KSIZEJ INTEGER(KIND=8), INTENT(IN) :: KTRUNC INTEGER(KIND=8), INTENT(IN) :: KSLOEN INTEGER(KIND=8), INTENT(IN) :: KSPOLEGL INTEGER(KIND=8), DIMENSION(KSLOEN), INTENT(IN) :: KLOEN INTEGER(KIND=8), INTENT(IN) :: KNUMMAXRESOL INTEGER(KIND=8), DIMENSION(KSLOEN), INTENT(OUT) :: KNMENG REAL(KIND=8), DIMENSION(KSLOEN), INTENT(OUT) :: PGW REAL(KIND=8), DIMENSION(KSLOEN/2,KSPOLEGL), INTENT(OUT) :: PRPNM ! ! II. Local variables declaration INTEGER, DIMENSION(KSLOEN) :: ILOEN INTEGER :: ISIZEI, ISIZEJ, & & IPHYSICALSIZEI, IPHYSICALSIZEJ, & & ITRUNCX, ITRUNCY, & & INUMMAXRESOL LOGICAL :: LLSTOP INTEGER :: IIDENTRESOL INTEGER, DIMENSION(KSLOEN) :: INMENG REAL(KIND=8), DIMENSION(KSLOEN) :: ZGW REAL(KIND=8), DIMENSION(KSLOEN/2,KSPOLEGL) :: ZRPNM REAL(KIND=8) :: ZDELTAX, ZDELTAY #include "trans_inq.h" ILOEN(:)=KLOEN(:) ISIZEI=0 ISIZEJ=KSIZEJ IPHYSICALSIZEI=0 IPHYSICALSIZEJ=0 ITRUNCX=KTRUNC ITRUNCY=0 INUMMAXRESOL=KNUMMAXRESOL ! ! III. Setup ZDELTAX=0. ZDELTAY=0. CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .FALSE., SIZE(ILOEN), & &ZDELTAX, ZDELTAY, IIDENTRESOL, LLSTOP) IF (.NOT. LLSTOP) THEN CALL TRANS_INQ(KRESOL=IIDENTRESOL, KNMENG=INMENG, PGW=ZGW, PRPNM=ZRPNM) KNMENG=INMENG PGW=ZGW PRPNM=ZRPNM ENDIF ! END SUBROUTINE GET_LEGENDRE_ASSETS ectrans-1.8.0/src/ectrans4py/etrans_inq4py.F900000664000175000017500000000414615174631767021334 0ustar alastairalastairSUBROUTINE ETRANS_INQ4PY(KRETURNCODE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & &KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELTAX, PDELTAY, & &KGPTOT, KSPEC) ! ** PURPOSE ! Simplified wrapper to ETRANS_INQ ! ! ** DUMMY ARGUMENTS ! KSIZEI, KSIZEJ: size of grid-point field (with extension zone) ! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field ! KTRUNCX, KTRUNCY: troncatures ! KNUMMAXRESOL: maximum number of troncatures handled ! PDELTAX: x resolution ! PDELTAY: y resolution ! KGPTOT: number of gridpoints ! KSPEC: number of spectral coefficients ! ! ** AUTHOR ! 9 April 2014, S. Riette ! ! ** MODIFICATIONS ! 6 Jan., S. Riette: PDELTAX and PDELTAY added ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 IMPLICIT NONE INTEGER(KIND=INT64), INTENT(OUT) :: KRETURNCODE INTEGER(KIND=INT64), INTENT(IN) :: KSIZEI, KSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KTRUNCX, KTRUNCY INTEGER(KIND=INT64), INTENT(IN) :: KNUMMAXRESOL REAL(KIND=REAL64), INTENT(IN) :: PDELTAX REAL(KIND=REAL64), INTENT(IN) :: PDELTAY INTEGER(KIND=INT64), INTENT(OUT) :: KGPTOT INTEGER(KIND=INT64), INTENT(OUT) :: KSPEC ! ! II. Local variables declaration INTEGER, DIMENSION(0:KTRUNCX) :: IESM0 INTEGER :: ISIZEI, ISIZEJ, & & IPHYSICALSIZEI, IPHYSICALSIZEJ, & & ITRUNCX, ITRUNCY, & & INUMMAXRESOL LOGICAL :: LLSTOP INTEGER :: IIDENTRESOL INTEGER, DIMENSION(1) :: ILOEN INTEGER :: IGPTOT, ISPEC #include "etrans_inq.h" ISIZEI=KSIZEI ISIZEJ=KSIZEJ IPHYSICALSIZEI=KPHYSICALSIZEI IPHYSICALSIZEJ=KPHYSICALSIZEJ ITRUNCX=KTRUNCX ITRUNCY=KTRUNCY INUMMAXRESOL=KNUMMAXRESOL ! III. Setup CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .TRUE., 1, & &PDELTAX, PDELTAY, IIDENTRESOL, LLSTOP) IF (.NOT. LLSTOP) THEN CALL ETRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KESM0=IESM0) KGPTOT=IGPTOT KSPEC=ISPEC ENDIF ! END SUBROUTINE ETRANS_INQ4PY ectrans-1.8.0/src/ectrans4py/sp2gp_fft1d4py.F900000664000175000017500000000652115174631767021307 0ustar alastairalastair! =================================== ! NOTE: this subroutine is not tested ! =================================== SUBROUTINE SP2GP_FFT1D4PY(KSIZES, KTRUNC, PSPEC, KSIZEG, PGPT) ! ** PURPOSE ! Transform spectral coefficients into grid-point values, ! for a 1D array (vertical section academic model) ! ! ** DUMMY ARGUMENTS ! KSIZES size of PSPEC ! KTRUNC: troncature ! PSPEC: spectral coefficient array ! KSIZEG: size of grid-point field (with extension zone) ! PGPT: grid-point field ! ! ** AUTHOR ! 26 March 2015, A. Mary, from utilities/pinuts/module/fa_datas_mod.F90 ! ! ** MODIFICATIONS ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 USE TPM_FFTW_DP, ONLY: EXEC_FFTW IMPLICIT NONE INTEGER(KIND=INT64), INTENT(IN) :: KSIZES INTEGER(KIND=INT64), INTENT(IN) :: KTRUNC REAL(KIND=REAL64), DIMENSION(KSIZES), INTENT(IN) :: PSPEC INTEGER(KIND=INT64), INTENT(IN) :: KSIZEG REAL(KIND=REAL64), DIMENSION(KSIZEG), INTENT(OUT) :: PGPT INTEGER(KIND=INT64) :: NFTM, NDGLSUR REAL(KIND=REAL64), DIMENSION(:,:), ALLOCATABLE :: SP2 INTEGER(KIND=INT64), PARAMETER :: NZERO=0 NDGLSUR = KSIZEG+MOD(KSIZEG,2)+2 NFTM = 2*(KTRUNC+1) ALLOCATE(SP2(1,NDGLSUR*NFTM)) SP2 = 0.0 SP2(1,:) = CONVRT2FFT(PSPEC,NZERO,KTRUNC,NDGLSUR) CALL EXEC_FFTW(1, INT(KSIZEG,4), (INT(KSIZEG,4)/2+1)*2, 1, 1, .FALSE., SP2(:,1:KSIZEG)) PGPT(:) = SP2(1,1:KSIZEG) CONTAINS ! from utilities/pinuts/module/fa_datas_mod.F90 ! and utilities/pinuts/module/array_lib_mod.F90 FUNCTION CONVRT2FFT(IN,X,Y,N) RESULT(OU) REAL(KIND=REAL64),DIMENSION(:),INTENT(IN) :: IN INTEGER(KIND=INT64),INTENT(IN) :: X, Y, N REAL(KIND=REAL64),DIMENSION(N*2*(X+1)) :: OU INTEGER(KIND=INT64),DIMENSION(2*(X+1),(N/2)) :: MINQ INTEGER(KIND=INT64),DIMENSION((N/2),2*(X+1)) :: TMINQ REAL(KIND=REAL64),DIMENSION(2*(X+1),(N/2)) :: OMINQ, EMINQ REAL(KIND=REAL64),DIMENSION((N/2),2*(X+1)) :: TOMINQ, TEMINQ REAL(KIND=REAL64),DIMENSION(N*(X+1)) :: OINI, EINI REAL(KIND=REAL64), PARAMETER :: ZZERO=0.0 CALL SPLIT_ODEV(IN,OINI,EINI) MINQ = MASQ(X,Y,N) OMINQ = UNPACK(OINI,MINQ == 1,ZZERO) TOMINQ = TRANSPOSE(OMINQ) EMINQ = UNPACK(EINI,MINQ == 1,ZZERO) TEMINQ = TRANSPOSE(EMINQ) TMINQ = 1 OINI = PACK(TOMINQ,TMINQ > 0) EINI = PACK(TEMINQ,TMINQ > 0) OU = MIX_ODEV(OINI,EINI) END FUNCTION CONVRT2FFT FUNCTION MASQ(X,Y,N) RESULT(T) INTEGER(KIND=INT64),INTENT(IN) :: X, Y, N INTEGER(KIND=INT64),DIMENSION(1:2*(X+1),1:(N/2)) :: T INTEGER(KIND=INT64) :: I, J INTEGER(KIND=INT64),DIMENSION(0:X) :: KM INTEGER(KIND=INT64),DIMENSION(0:Y) :: KN CALL ELLIPS(INT(X,4),INT(Y,4),INT(KN,4),INT(KM,4)) T = 0 DO I=0,Y DO J=0,2*KN(I)+1 T(J+1,I+1)=1 END DO END DO END FUNCTION MASQ FUNCTION MIX_ODEV(TO,TE) RESULT(T) REAL(KIND=REAL64),DIMENSION(:),INTENT(IN) :: TO,TE REAL(KIND=REAL64),DIMENSION(SIZE(TO)+SIZE(TE)) :: T INTEGER(KIND=INT64) :: I DO I=1,(SIZE(TO)+SIZE(TE))/2 T((2*I)-1)=TE(I) T(2*I)=TO(I) END DO END FUNCTION MIX_ODEV SUBROUTINE SPLIT_ODEV(T,TO,TE) REAL(KIND=REAL64),DIMENSION(:),INTENT(IN) :: T REAL(KIND=REAL64),DIMENSION(SIZE(T)/2),INTENT(OUT) :: TO,TE INTEGER(KIND=INT64) :: I DO I=1,SIZE(T)/2 TO(I)=T(2*I) TE(I)=T((2*I)-1) END DO END SUBROUTINE SPLIT_ODEV END SUBROUTINE SP2GP_FFT1D4PYectrans-1.8.0/src/ectrans4py/sp2gp_gauss4py.F900000664000175000017500000000733615174631767021432 0ustar alastairalastairSUBROUTINE SP2GP_GAUSS4PY(KRETURNCODE, KSIZEJ, KTRUNC, KNUMMAXRESOL, KGPTOT, KSLOEN, KLOEN, KSIZE, & & LGRADIENT, LREORDER, PSPEC, PGPT, PGPTM, PGPTL) ! ** PURPOSE ! Transform spectral coefficients into grid-point values ! ! ** DUMMY ARGUMENTS ! KSIZEJ: Number of latitudes ! KTRUNC: troncature ! KNUMMAXRESOL: maximum number of troncatures handled ! KGPTOT: number of grid-points ! KSLOEN: Size of KLOEN ! KLOEN: ! KSIZE: Size of PSPEC ! LREORDER: switch to reorder spectral coefficients or not ! LGRADIENT: switch to compute or not gradient ! PSPEC: spectral coefficient array ! PGPT: grid-point field ! PGPTM: N-S derivative if LGRADIENT ! PGPTL: E-W derivative if LGRADIENT ! ! ** AUTHOR ! 9 April 2014, S. Riette ! ! ** MODIFICATIONS ! 6 Jan., S. Riette: w_spec_setup interface modified ! March, 2016, A.Mary: LREORDER ! Sept., 2016, A.Mary: LGRADIENT ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 USE PARKIND1, ONLY : JPRB USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_BOOL IMPLICIT NONE INTEGER(KIND=INT64), INTENT(OUT) :: KRETURNCODE INTEGER(KIND=INT64), INTENT(IN) :: KSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KTRUNC INTEGER(KIND=INT64), INTENT(IN) :: KNUMMAXRESOL INTEGER(KIND=INT64), INTENT(IN) :: KGPTOT INTEGER(KIND=INT64), INTENT(IN) :: KSLOEN INTEGER(KIND=INT64), DIMENSION(KSLOEN), INTENT(IN) :: KLOEN INTEGER(KIND=INT64), INTENT(IN) :: KSIZE LOGICAL(KIND=C_BOOL), INTENT(IN) :: LGRADIENT LOGICAL(KIND=C_BOOL), INTENT(IN) :: LREORDER REAL(KIND=REAL64), DIMENSION(KSIZE), INTENT(IN) :: PSPEC REAL(KIND=REAL64), DIMENSION(KGPTOT), INTENT(OUT) :: PGPT REAL(KIND=REAL64), DIMENSION(KGPTOT), INTENT(OUT) :: PGPTM REAL(KIND=REAL64), DIMENSION(KGPTOT), INTENT(OUT) :: PGPTL ! ! II. Local variables declaration INTEGER, DIMENSION(SIZE(KLOEN)) :: ILOEN INTEGER :: ISIZEI, ISIZEJ, & & IPHYSICALSIZEI, IPHYSICALSIZEJ, & & ITRUNCX, ITRUNCY, & & INUMMAXRESOL LOGICAL :: LLSTOP INTEGER :: IIDENTRESOL INTEGER :: JI, JM, JN INTEGER, DIMENSION(0:KTRUNC) :: NASM0 REAL(KIND=REAL64), DIMENSION(1, KSIZE) :: ZSPBUF REAL(KIND=JPRB), DIMENSION(:,:,:), ALLOCATABLE :: ZGPBUF REAL(KIND=REAL64) :: ZDELTAX, ZDELTAY #include "trans_inq.h" #include "inv_trans.h" ILOEN(:)=KLOEN(:) ISIZEI=0 ISIZEJ=KSIZEJ IPHYSICALSIZEI=0 IPHYSICALSIZEJ=0 ITRUNCX=KTRUNC ITRUNCY=0 INUMMAXRESOL=KNUMMAXRESOL ! ! III. Setup ZDELTAX=0. ZDELTAY=0. CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .FALSE., SIZE(ILOEN), & &ZDELTAX, ZDELTAY, IIDENTRESOL, LLSTOP) ! ! IV. Transformation IF (LREORDER) THEN ! IV.a Shape of coefficient array IF (.NOT. LLSTOP) THEN JI=1 DO JN=0, KTRUNC NASM0(JN)=JI JI=JI+1+JN+(JN+1) ENDDO ENDIF ! IV.b Reordering IF(.NOT. LLSTOP) THEN ZSPBUF(1,:)=0. JI=1 DO JM=0, KTRUNC DO JN=JM, KTRUNC ZSPBUF(1,JI)=PSPEC(NASM0(JN)+JM) JI=JI+1 IF(JM==0) THEN ZSPBUF(1,JI)=0 ELSE ZSPBUF(1,JI)=PSPEC(NASM0(JN)-JM) ENDIF JI=JI+1 ENDDO ENDDO ENDIF ELSE ZSPBUF(1,:) = PSPEC(:) ENDIF ! IV.c Inverse transform IF (.NOT. LLSTOP) THEN IF (.NOT. LGRADIENT) THEN ALLOCATE(ZGPBUF(KGPTOT, 1, 1)) CALL INV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) ELSE ALLOCATE(ZGPBUF(KGPTOT, 3, 1)) CALL INV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL, LDSCDERS=.TRUE.) PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) PGPTM(:)=REAL(ZGPBUF(:,2,1),KIND=8) PGPTL(:)=REAL(ZGPBUF(:,3,1),KIND=8) ENDIF ENDIF END SUBROUTINE SP2GP_GAUSS4PY ectrans-1.8.0/src/ectrans4py/sp2gp_lam4py.F900000664000175000017500000001141015174631767021045 0ustar alastairalastairSUBROUTINE SP2GP_LAM4PY(KRETURNCODE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & &KTRUNCX, KTRUNCY, KNUMMAXRESOL, KSIZE, LGRADIENT, LREORDER, PDELTAX, PDELTAY, & &PSPEC, PGPT, PGPTM, PGPTL) ! ** PURPOSE ! Transform spectral coefficients into grid-point values ! ! ** DUMMY ARGUMENTS ! KRETURNCODE: error code ! KSIZEI, KSIZEJ: size of grid-point field (with extension zone) ! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field ! KTRUNCX, KTRUNCY: troncatures ! KNUMMAXRESOL: maximum number of troncatures handled ! KSIZE: size of PSPEC ! LREORDER: switch to reorder spectral coefficients or not ! LGRADIENT: switch to compute or not gradient ! PDELTAX: x resolution ! PDELTAY: y resolution ! PSPEC: spectral coefficient array ! PGPT: grid-point field ! PGPTM: N-S derivative if LGRADIENT ! PGPTL: E-W derivative if LGRADIENT ! ! ** AUTHOR ! 9 April 2014, S. Riette ! ! ** MODIFICATIONS ! 5 Jan., S. Riette: PDELTAX, PDELTAY, LGRADIENT, PGPTM and PGPTL added ! March, 2016, A.Mary: LREORDER ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 USE PARKIND1, ONLY : JPRB USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_BOOL IMPLICIT NONE INTEGER(KIND=INT64), INTENT(OUT) :: KRETURNCODE INTEGER(KIND=INT64), INTENT(IN) :: KSIZEI, KSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KTRUNCX, KTRUNCY INTEGER(KIND=INT64), INTENT(IN) :: KNUMMAXRESOL INTEGER(KIND=INT64), INTENT(IN) :: KSIZE LOGICAL(KIND=C_BOOL), INTENT(IN) :: LGRADIENT LOGICAL(KIND=C_BOOL), INTENT(IN) :: LREORDER REAL(KIND=REAL64), INTENT(IN) :: PDELTAX REAL(KIND=REAL64), INTENT(IN) :: PDELTAY REAL(KIND=REAL64), DIMENSION(KSIZE), INTENT(IN) :: PSPEC REAL(KIND=REAL64), DIMENSION(KSIZEI*KSIZEJ), INTENT(OUT) :: PGPT REAL(KIND=REAL64), DIMENSION(KSIZEI*KSIZEJ), INTENT(OUT) :: PGPTM REAL(KIND=REAL64), DIMENSION(KSIZEI*KSIZEJ), INTENT(OUT) :: PGPTL ! ! II. Local variables declaration INTEGER, DIMENSION(0:KTRUNCX) :: IESM0 INTEGER :: IGPTOT, ISPEC INTEGER, DIMENSION(0:KTRUNCY) :: ISPECINI, ISPECEND REAL(KIND=REAL64), DIMENSION(1, KSIZE) :: ZSPBUF REAL(KIND=JPRB), DIMENSION(KSIZEI*KSIZEJ, 3, 1) :: ZGPBUF INTEGER :: JI, JM, JN, IINDEX, IIDENTRESOL LOGICAL :: LLSTOP INTEGER :: ISIZEI, ISIZEJ, & & IPHYSICALSIZEI, IPHYSICALSIZEJ, & & ITRUNCX, ITRUNCY, & & INUMMAXRESOL INTEGER, DIMENSION(1) :: ILOEN #include "einv_trans.h" #include "etrans_inq.h" KRETURNCODE=0 LLSTOP=.FALSE. ISIZEI=KSIZEI ISIZEJ=KSIZEJ IPHYSICALSIZEI=KPHYSICALSIZEI IPHYSICALSIZEJ=KPHYSICALSIZEJ ITRUNCX=KTRUNCX ITRUNCY=KTRUNCY INUMMAXRESOL=KNUMMAXRESOL ILOEN(:)=0 ! III. Setup CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .TRUE., 1, & &PDELTAX, PDELTAY, IIDENTRESOL, LLSTOP) ! IV. Transformation ! IV.a Shape of coefficient array !IGPTOT is the total number of points in grid-point space !ISPEC is the number of spectral coefficients !IESM0(m) is the index of spectral coefficient (m,0) in model !ISPECINI(n) is the index of the first of the 4 spectral coefficient (0,n) in FA file !ISPECEND(n) is the index of the last of the last 4 spectral coefficients (:,n) in FA file IF (.NOT. LLSTOP) THEN CALL ETRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KESM0=IESM0) JI=1 DO JN=0, ITRUNCY ISPECINI(JN)=(JI-1)*4+1 JI=JI+COUNT(IESM0(1:ITRUNCX)-IESM0(0:ITRUNCX-1)>JN*4) IF (ISPEC-IESM0(ITRUNCX)>JN*4) JI=JI+1 ISPECEND(JN)=(JI-1)*4 ENDDO ENDIF ! III.b Reordering ! reorder Aladin : file ordering = coeffs per blocks of m, 4 reals per coeff ! Aladin array ordering = coeffs per blocks of n, 4 reals per coeff IF (LREORDER) THEN IF (.NOT. LLSTOP) THEN ZSPBUF(:,:)=0. JI=1 DO JM=0,ITRUNCX+1 DO JN=0,ITRUNCY IF (ISPECINI(JN)+JM*4+3<=ISPECEND(JN)) THEN DO IINDEX=ISPECINI(JN)+JM*4, ISPECINI(JN)+JM*4+3 ZSPBUF(1,JI)=PSPEC(IINDEX) JI=JI+1 ENDDO ENDIF ENDDO ENDDO IF (JI/=ISPEC+1) THEN PRINT*, "Internal error in SP2GP_LAM4PY (spectral reordering)" KRETURNCODE=-999 LLSTOP=.TRUE. ENDIF ENDIF ELSE ZSPBUF(1,:) = PSPEC(:) ENDIF ! III.c Inverse transform IF (.NOT. LLSTOP) THEN IF (.NOT. LGRADIENT) THEN CALL EINV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) ELSE CALL EINV_TRANS(PSPSCALAR=REAL(ZSPBUF(:,:),KIND=JPRB), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL, LDSCDERS=.TRUE.) PGPT(:)=REAL(ZGPBUF(:,1,1),KIND=8) PGPTM(:)=REAL(ZGPBUF(:,2,1),KIND=8) PGPTL(:)=REAL(ZGPBUF(:,3,1),KIND=8) ENDIF ENDIF END SUBROUTINE SP2GP_LAM4PY ectrans-1.8.0/src/ectrans4py/gp2sp_lam4py.F900000664000175000017500000001003615174631767021050 0ustar alastairalastairSUBROUTINE GP2SP_LAM4PY(KRETURNCODE, KSIZE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & &KTRUNCX, KTRUNCY, KNUMMAXRESOL, PDELTAX, PDELTAY, LREORDER, PGPT, PSPEC) ! ** PURPOSE ! Transform grid point values into spectral coefficients ! ! ** DUMMY ARGUMENTS ! KRETURNCODE: error code ! KSIZE: size of spectral field ! KSIZEI, KSIZEJ: size of grid-point field (with extension zone) ! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field ! KTRUNCX, KTRUNCY: troncatures ! KNUMMAXRESOL: maximum number of troncatures handled ! PDELTAX: x resolution ! PDELTAY: y resolution ! LREORDER: switch to reorder spectral coefficients or not ! PGPT: grid-point field ! PSPEC: spectral coefficient array ! ! ** AUTHOR ! 9 April 2014, S. Riette ! ! ** MODIFICATIONS ! 6 Jan., S. Riette: PDELTAX and PDELTAY added ! March, 2016, A.Mary: LREORDER ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 USE PARKIND1, ONLY : JPRB USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_BOOL IMPLICIT NONE INTEGER(KIND=INT64), INTENT(OUT) :: KRETURNCODE INTEGER(KIND=INT64), INTENT(IN) :: KSIZE, KSIZEI, KSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ INTEGER(KIND=INT64), INTENT(IN) :: KTRUNCX, KTRUNCY INTEGER(KIND=INT64), INTENT(IN) :: KNUMMAXRESOL REAL(KIND=REAL64), INTENT(IN) :: PDELTAX REAL(KIND=REAL64), INTENT(IN) :: PDELTAY LOGICAL(KIND=C_BOOL), INTENT(IN) :: LREORDER REAL(KIND=REAL64), DIMENSION(KSIZEI*KSIZEJ), INTENT(IN) :: PGPT REAL(KIND=REAL64), DIMENSION(KSIZE), INTENT(OUT) :: PSPEC ! ! II. Local variables declaration INTEGER, DIMENSION(0:KTRUNCX) :: IESM0 INTEGER :: IGPTOT, ISPEC INTEGER, DIMENSION(0:KTRUNCY) :: ISPECINI, ISPECEND REAL(KIND=JPRB), DIMENSION(1, KSIZEI*KSIZEJ) :: ZSPBUF !size over-evaluated REAL(KIND=JPRB), DIMENSION(KSIZEI*KSIZEJ, 1, 1) :: ZGPBUF INTEGER :: JI, JM, JN, IIDENTRESOL LOGICAL :: LLSTOP INTEGER :: ISIZEI, ISIZEJ, & & IPHYSICALSIZEI, IPHYSICALSIZEJ, & & ITRUNCX, ITRUNCY, & & INUMMAXRESOL INTEGER, DIMENSION(1) :: ILOEN #include "edir_trans.h" #include "etrans_inq.h" KRETURNCODE=0 LLSTOP=.FALSE. ISIZEI=KSIZEI ISIZEJ=KSIZEJ IPHYSICALSIZEI=KPHYSICALSIZEI IPHYSICALSIZEJ=KPHYSICALSIZEJ ITRUNCX=KTRUNCX ITRUNCY=KTRUNCY INUMMAXRESOL=KNUMMAXRESOL ! III. Setup CALL SPEC_SETUP4PY(KRETURNCODE, ISIZEI, ISIZEJ, IPHYSICALSIZEI, IPHYSICALSIZEJ, & &ITRUNCX, ITRUNCY, INUMMAXRESOL, ILOEN, .TRUE., 1, & &PDELTAX, PDELTAY, IIDENTRESOL, LLSTOP) ! IV. Transformation ! IV.a Shape of coefficient array !IGPTOT is the total number of points in grid-point space !ISPEC is the number of spectral coefficients !IESM0(m) is the index of spectral coefficient (m,0) in model !ISPECINI(n) is the index of the first of the 4 spectral coefficient (0,n) in FA file !ISPECEND(n) is the index of the last of the last 4 spectral coefficients (:,n) in FA file IF (.NOT. LLSTOP) THEN CALL ETRANS_INQ(KRESOL=IIDENTRESOL, KGPTOT=IGPTOT, KSPEC=ISPEC, KESM0=IESM0) JI=1 DO JN=0, ITRUNCY ISPECINI(JN)=(JI-1)*4+1 JI=JI+COUNT(IESM0(1:ITRUNCX)-IESM0(0:ITRUNCX-1)>JN*4) IF (ISPEC-IESM0(ITRUNCX)>JN*4) JI=JI+1 ISPECEND(JN)=(JI-1)*4 ENDDO ENDIF ! III.b transform IF (.NOT. LLSTOP) THEN ZGPBUF(:,1,1)=REAL(PGPT(:),KIND=JPRB) CALL EDIR_TRANS(PSPSCALAR=ZSPBUF(:,:), PGP=ZGPBUF(:,:,:), KRESOL=IIDENTRESOL) ENDIF ! III.c Reordering ! reorder Aladin : file ordering = coeffs per blocks of m, 4 reals per coeff ! Aladin array ordering = coeffs per blocks of n, 4 reals per coeff IF (LREORDER) THEN IF (.NOT. LLSTOP) THEN JI=1 PSPEC(:)=0. DO JM=0,ITRUNCX*4+4,4 DO JN=0,ITRUNCY IF (ISPECINI(JN)+JM+3<=ISPECEND(JN)) THEN PSPEC(ISPECINI(JN)+JM:ISPECINI(JN)+JM+3) = REAL(ZSPBUF(1,JI:JI+3),KIND=8) JI=JI+4 ENDIF ENDDO ENDDO IF(JI/=ISPEC+1) THEN PRINT*, "Internal error in GP2SP_LAM4PY (spectral reordering)" KRETURNCODE=-999 ENDIF ENDIF ELSE PSPEC(1:KSIZE) = REAL(ZSPBUF(1,1:KSIZE),KIND=8) ENDIF END SUBROUTINE GP2SP_LAM4PY ectrans-1.8.0/src/ectrans4py/CMakeLists.txt0000664000175000017500000000070615174631767021012 0ustar alastairalastair# (using CMAKE_CURRENT_SOURCE_DIR is necessary because sources are in a different directory than the target library (trans_${prec})) ecbuild_list_add_pattern( LIST ectrans4py_src GLOB ${CMAKE_CURRENT_SOURCE_DIR}/*.F90 QUIET ) # Add ectrans4py library ecbuild_add_library( TARGET ectrans4py_dp LINKER_LANGUAGE Fortran SOURCES ${ectrans4py_src} PUBLIC_LIBS fiat trans_dp parkind_dp etrans_dp ) ectrans-1.8.0/src/ectrans4py/spec_setup4py.F900000664000175000017500000001332615174631767021343 0ustar alastairalastairSUBROUTINE SPEC_SETUP4PY(KRETURNCODE, KSIZEI, KSIZEJ, KPHYSICALSIZEI, KPHYSICALSIZEJ, & &KTRUNCX, KTRUNCY, KNUMMAXRESOL, KLOEN, LDLAM, & &KSIZEKLOEN, PDELTAX, PDELTAY, & &KIDENTRESOL, LDSTOP) ! ** PURPOSE ! Setup spectral transform for LAM and global ! ! ** DUMMY ARGUMENTS ! KRETURNCODE: error code ! KSIZEI, KSIZEJ: size of grid-point field (with extension zone for LAM), put max size for KSIZEI in global ! KPHYSICALSIZEI, KPHYSICALSIZEJ: size of physical part of grid-point field for LAM (put 0 for global) ! KTRUNCX, KTRUNCY: troncatures for LAM (only KTRUNCX is used for global, put 0 for KTRUNCY) ! KNUMMAXRESOL: maximum number of troncatures handled ! KLOEN: number of points on each latitude row ! KSIZEKLOEN: size of KLOEN array ! PDELTAX: x resolution ! PDELTAY: y resolution ! LDLAM: LAM (.TRUE.) or global (.FALSE.) ! KIDENTRESOL: identification of resolution ! LDSTOP: exception raised? ! ! ** AUTHOR ! 9 April 2014, S. Riette ! ! ** MODIFICATIONS ! 6 Jan 2016, S. Riette: PDELTAX and PDELTAY added ! 31 Jan 2019 R. El Khatib fix for single precision compilation ! ! I. Dummy arguments declaration USE ISO_FORTRAN_ENV, ONLY: INT64, REAL64 USE PARKIND1, ONLY : JPRB IMPLICIT NONE INTEGER(KIND=INT64), INTENT(OUT) :: KRETURNCODE INTEGER, INTENT(IN) :: KSIZEI, KSIZEJ INTEGER, INTENT(IN) :: KPHYSICALSIZEI, KPHYSICALSIZEJ INTEGER, INTENT(IN) :: KTRUNCX, KTRUNCY INTEGER, INTENT(IN) :: KNUMMAXRESOL INTEGER, DIMENSION(KSIZEKLOEN), INTENT(IN) :: KLOEN LOGICAL, INTENT(IN) :: LDLAM INTEGER, INTENT(IN) :: KSIZEKLOEN REAL(KIND=REAL64), INTENT(IN) :: PDELTAX REAL(KIND=REAL64), INTENT(IN) :: PDELTAY INTEGER, INTENT(OUT) :: KIDENTRESOL LOGICAL, INTENT(OUT) :: LDSTOP ! ! II. Local variables declaration INTEGER, DIMENSION(2*KSIZEJ) :: ILOEN INTEGER :: JI LOGICAL, SAVE :: LLFIRSTCALL=.TRUE. LOGICAL :: LLNEWRESOL INTEGER, SAVE :: INBRESOL=0 INTEGER(KIND=INT64) :: ICODEILOEN INTEGER, SAVE :: INUMMAXRESOLSAVE=-1 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: ITRUNCXSAVE, ITRUNCYSAVE, & IPHYSICALSIZEISAVE, & IPHYSICALSIZEJSAVE, & ISIZEISAVE, ISIZEJSAVE, & IIDENTRESOLSAVE INTEGER(KIND=INT64), DIMENSION(:), ALLOCATABLE, SAVE :: ILOENSAVE REAL(KIND=REAL64), DIMENSION(:), ALLOCATABLE, SAVE :: ZDELTAXSAVE, & ZDELTAYSAVE REAL(KIND=REAL64) :: ZEXWN, ZEYWN #include "setup_trans0.h" #include "esetup_trans.h" #include "setup_trans.h" KRETURNCODE=0 LDSTOP=.FALSE. ! III. Setup ! III.a Setup LAM and global spectral transform - all resolutions ! Maximum number of resolution is set now and cannot be change anymore IF (LLFIRSTCALL) THEN !This code is called only once, whatever is the number of resolutions CALL SETUP_TRANS0(KPRINTLEV=0, LDMPOFF=.TRUE., KMAX_RESOL=KNUMMAXRESOL) ALLOCATE(ITRUNCXSAVE(KNUMMAXRESOL)) ALLOCATE(ITRUNCYSAVE(KNUMMAXRESOL)) ALLOCATE(IPHYSICALSIZEISAVE(KNUMMAXRESOL)) ALLOCATE(IPHYSICALSIZEJSAVE(KNUMMAXRESOL)) ALLOCATE(ISIZEJSAVE(KNUMMAXRESOL)) ALLOCATE(ISIZEISAVE(KNUMMAXRESOL)) ALLOCATE(ILOENSAVE(KNUMMAXRESOL)) ALLOCATE(IIDENTRESOLSAVE(KNUMMAXRESOL)) ALLOCATE(ZDELTAXSAVE(KNUMMAXRESOL)) ALLOCATE(ZDELTAYSAVE(KNUMMAXRESOL)) ITRUNCXSAVE=-1 ITRUNCYSAVE=-1 IPHYSICALSIZEISAVE=-1 IPHYSICALSIZEJSAVE=-1 ISIZEJSAVE=-1 ISIZEISAVE=-1 ILOENSAVE=-1 IIDENTRESOLSAVE=-1 ZDELTAXSAVE=-1. ZDELTAXSAVE=-1. LLFIRSTCALL=.FALSE. INUMMAXRESOLSAVE=KNUMMAXRESOL ENDIF ! ! III.b Is-it a new resolution? LLNEWRESOL=.TRUE. IF(LDLAM) THEN ILOEN(:)=KSIZEI ELSE ILOEN(:)=0 ILOEN(1:MIN(SIZE(ILOEN),SIZE(KLOEN)))=KLOEN(1:MIN(SIZE(ILOEN),SIZE(KLOEN))) ENDIF ICODEILOEN=0 DO JI=1, SIZE(ILOEN) ICODEILOEN=ICODEILOEN+ILOEN(JI)*JI**4 ENDDO DO JI=1, INBRESOL IF (KTRUNCX==ITRUNCXSAVE(JI) .AND. KTRUNCY==ITRUNCYSAVE(JI) .AND. & &KPHYSICALSIZEI==IPHYSICALSIZEISAVE(JI) .AND. & &KPHYSICALSIZEJ==IPHYSICALSIZEJSAVE(JI) .AND. & &KSIZEJ==ISIZEJSAVE(JI) .AND. KSIZEI==ISIZEISAVE(JI) .AND. & &ICODEILOEN==ILOENSAVE(JI) .AND. & &PDELTAX==ZDELTAXSAVE(JI) .AND. PDELTAY==ZDELTAYSAVE(JI)) THEN KIDENTRESOL=IIDENTRESOLSAVE(JI) LLNEWRESOL=.FALSE. ENDIF ENDDO IF(LLNEWRESOL) THEN INBRESOL=INBRESOL+1 IF(INBRESOL>INUMMAXRESOLSAVE) THEN PRINT*, "Error in SPEC_SETUP4PY : Maximum number of resolution is exceeded." KRETURNCODE=-999 LDSTOP=.TRUE. ENDIF ENDIF ! ! III.c Setup LAM or global spectral transform - once by resolution IF(LLNEWRESOL .AND. .NOT. LDSTOP) THEN ! The following code is exectuded once for each resolution ITRUNCXSAVE(INBRESOL)=KTRUNCX ITRUNCYSAVE(INBRESOL)=KTRUNCY IPHYSICALSIZEISAVE(INBRESOL)=KPHYSICALSIZEI IPHYSICALSIZEJSAVE(INBRESOL)=KPHYSICALSIZEJ ISIZEISAVE(INBRESOL)=KSIZEI ISIZEJSAVE(INBRESOL)=KSIZEJ ILOENSAVE(INBRESOL)=ICODEILOEN ZDELTAXSAVE(INBRESOL)=PDELTAX ZDELTAYSAVE(INBRESOL)=PDELTAY IF(LDLAM) THEN ZEXWN=2*3.141592653589797/(KSIZEI*PDELTAX) ZEYWN=2*3.141592653589797/(KSIZEJ*PDELTAY) CALL ESETUP_TRANS(KMSMAX=ITRUNCXSAVE(INBRESOL), KSMAX=ITRUNCYSAVE(INBRESOL), & &KDGUX=IPHYSICALSIZEJSAVE(INBRESOL), & &KDGL=ISIZEJSAVE(INBRESOL), KLOEN=ILOEN(:), KRESOL=IIDENTRESOLSAVE(INBRESOL), & &PEXWN=REAL(ZEXWN,KIND=JPRB), PEYWN=REAL(ZEYWN,KIND=JPRB)) ELSE PRINT*, "Setup spectral transform" CALL SETUP_TRANS(KSMAX=ITRUNCXSAVE(INBRESOL), KDGL=ISIZEJSAVE(INBRESOL), & &KLOEN=ILOEN(1:ISIZEJSAVE(INBRESOL)), KRESOL=IIDENTRESOLSAVE(INBRESOL)) PRINT*, "End Setup spectral transform" ENDIF KIDENTRESOL=IIDENTRESOLSAVE(INBRESOL) ENDIF END SUBROUTINE SPEC_SETUP4PY ectrans-1.8.0/src/CMakeLists.txt0000664000175000017500000000107315174631767016714 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. add_subdirectory( trans ) add_subdirectory( programs ) if( HAVE_TRANSI ) add_subdirectory(transi) endif() add_subdirectory(etrans) if(HAVE_ECTRANS4PY) add_subdirectory(ectrans4py) endif() ectrans-1.8.0/README.md0000664000175000017500000000541615174631767014651 0ustar alastairalastairecTrans ======= ecTrans is a library for performing efficient and scalable spectral transformations. It is used for transforming fields from a grid point space on the sphere (e.g. latitude-longitude) to a spectral space based on spherical harmonics (for global transformations) or bifourier harmonics (for limited area transformations), which constitutes a direct transform. A corresponding inverse transform can also be performed. A transform consists of a Fourier transform in the longitudinal direction and either a Legendre transform (global) or another Fourier transform (limited area) in the latitudinal direction. ecTrans can also operate on fields which are distributed across separate MPI tasks and performs the necessary communication to ensure all data needed for a particular transform are resident on a local task. After co-development as part of the [Integrated Forecasting System (IFS)](https://www.ecmwf.int/en/forecasts/documentation-and-support/changes-ecmwf-model) atmospheric model of the [European Centre for Medium-Range Weather Forecasts](https://www.ecmwf.int/) for several decades, ecTrans became a standalone software package in 2022. It constitutes one of the most important and expensive parts of the IFS and neatly encapsulates both computational and communicational paradigms and bottlenecks exhibited by the IFS model as a whole. ecTrans primarily targets conventional CPU platforms, requiring FFTW- and BLAS-implementing libraries. It can also operate efficiently on GPU accelerators making use of offloading directives (either OpenACC or OpenMP) and vendor library routines (cuBLAS/cuFFT or hipBLAS/hipFFT). ecTrans performs efficiently and stably on Nvidia platforms but is currently less mature on AMD platforms. To learn more about ecTrans, please consult the [documentation](https://sites.ecmwf.int/docs/ectrans/page/index.html) (which is under construction). License ------- ecTrans is distributed under the Apache License Version 2.0. See `LICENSE` file for details. Installing ecTrans ------------------ Please consult the [documentation](https://sites.ecmwf.int/docs/ectrans/page/installation.html). Reporting Bugs -------------- Please report bugs using a [GitHub issue](https://github.com/ecmwf-ifs/ectrans/issues). Support is given on a best-effort basis by package developers. Contributing ------------ Contributions to ecTrans are welcome. In order to do so, please open a [GitHub issue](https://github.com/ecmwf-ifs/ectrans/issues) where a feature request or bug can be discussed. Then create a [pull request](https://github.com/ecmwf-ifs/ectrans/pulls) to the develop branch (not the main branch) with your contribution. All contributors to the pull request need to sign the [contributors license agreement (CLA)](https://bol-claassistant.ecmwf.int/ecmwf-ifs/ectrans). ectrans-1.8.0/setup.py0000664000175000017500000000132415174631767015076 0ustar alastairalastairimport os import ast from skbuild import setup _version_file = os.path.join(os.path.dirname(os.path.abspath(__file__)), "VERSION") with open(_version_file, "r") as f: __version__ = f.read().strip() setup( name="ectrans4py", version=__version__, packages=['ectrans4py'], cmake_minimum_required_version="3.13", cmake_args=[ '-DENABLE_ETRANS=ON', '-DENABLE_ECTRANS4PY=ON', '-DENABLE_SINGLE_PRECISION=OFF', '-DENABLE_OMP=ON', '-DFFTW_USE_STATIC_LIBS=ON', ], package_dir={"": "src"}, cmake_install_dir="src/ectrans4py", setup_requires=["scikit-build", "setuptools"], install_requires=["numpy", "ctypesForFortran >=1.3.0, !=2.0.*, !=2.1.*"], ) ectrans-1.8.0/.gitignore0000664000175000017500000000016615174631767015357 0ustar alastairalastair.vscode CMakeLists.txt.user* *.autosave *.sublime-workspace *.swp .nfs* build/* install/* env.sh *.DS_Store *.py[co~] ectrans-1.8.0/LICENSE0000664000175000017500000002500315174631767014371 0ustar alastairalastair Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS Copyright 1996-2018 ECMWF Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. ectrans-1.8.0/cmake/0000775000175000017500000000000015174631767014444 5ustar alastairalastairectrans-1.8.0/cmake/ectrans_macros.cmake0000664000175000017500000000221715174631767020453 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. ### Workaround to extract GIT_SHA1 from parent directory if( NOT ${PROJECT_NAME}_GIT_SHA1 ) get_filename_component( PARENT_DIR ${PROJECT_SOURCE_DIR} DIRECTORY ) if( EXISTS ${PARENT_DIR}/.git ) get_filename_component( PARENT_REPOSITORY_NAME ${PARENT_DIR} NAME_WE ) get_git_head_revision( GIT_REFSPEC ${PROJECT_NAME}_GIT_SHA1 ) string( SUBSTRING "${${PROJECT_NAME}_GIT_SHA1}" 0 7 ${PROJECT_NAME}_GIT_SHA1_SHORT ) set( ${PROJECT_NAME}_GIT_SHA1_SHORT "${PARENT_REPOSITORY_NAME}/${${PROJECT_NAME}_GIT_SHA1_SHORT}" ) set( ${PROJECT_NAME}_GIT_SHA1 "${PARENT_REPOSITORY_NAME}/${${PROJECT_NAME}_GIT_SHA1}" ) endif() endif() include( ectrans_find_lapack ) include( ectrans_find_cuda ) include( ectrans_find_hip ) include( CheckLanguage ) ectrans-1.8.0/cmake/ectrans-import.cmake.in0000664000175000017500000000557615174631767021037 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. # Import for trans package # # This file is included during # # find_package( ectrans [COMPONENTS (double|single|transi)] [QUIET] [REQUIRED] ) # # Supported COMPONENTS: double single transi # # If available following targets will be exported: # - trans_dp Double precision trans library # - trans_sp Single precision trans library # - transi_dp Double precision transi library (C interface to trans_dp) # ################################################################## ## Export project variables set( ectrans_VERSION_STR @ectrans_VERSION_STR@ ) set( ectrans_HAVE_MPI @ectrans_HAVE_MPI@ ) set( ectrans_HAVE_OMP @ectrans_HAVE_OMP@ ) set( ectrans_HAVE_ETRANS @ectrans_HAVE_ETRANS@ ) set( ectrans_HAVE_TRANSI @ectrans_HAVE_TRANSI@ ) set( ectrans_HAVE_SINGLE_PRECISION @ectrans_HAVE_SINGLE_PRECISION@ ) set( ectrans_HAVE_DOUBLE_PRECISION @ectrans_HAVE_DOUBLE_PRECISION@ ) set( ectrans_REQUIRES_PRIVATE_DEPENDENCIES @PACKAGE_REQUIRES_PRIVATE_DEPENDENCIES@ ) if ( ectrans_HAVE_TRANSI AND ectrans_HAVE_ETRANS ) set( ectrans_HAVE_TRANSI_LAM 1) else() set( ectrans_HAVE_TRANSI_LAM 0) endif() set( ectrans_HAVE_FFTW 1 ) # this is now mandatory if( NOT ${CMAKE_FIND_PACKAGE_NAME}_FIND_QUIETLY ) message( STATUS "Found ectrans version ${ectrans_VERSION_STR}" ) endif() ################################################################## ## Export project dependencies include( CMakeFindDependencyMacro ) if( ectrans_REQUIRES_PRIVATE_DEPENDENCIES OR CMAKE_Fortran_COMPILER_LOADED ) foreach( lang C CXX Fortran ) if (NOT CMAKE_${lang}_COMPILER_LOADED) enable_language( ${lang} ) endif() endforeach() if( trans_HAVE_OMP AND NOT TARGET OpenMP::OpenMP_Fortran ) find_dependency( OpenMP COMPONENTS Fortran ) endif() find_dependency( fiat HINTS ${CMAKE_CURRENT_LIST_DIR}/../fiat @fiat_DIR@ ) endif() ################################################################## ## Handle components set( ${CMAKE_FIND_PACKAGE_NAME}_single_FOUND ${ectrans_HAVE_SINGLE_PRECISION} ) set( ${CMAKE_FIND_PACKAGE_NAME}_double_FOUND ${ectrans_HAVE_DOUBLE_PRECISION} ) set( ${CMAKE_FIND_PACKAGE_NAME}_transi_FOUND ${ectrans_HAVE_TRANSI} ) foreach( _component ${${CMAKE_FIND_PACKAGE_NAME}_FIND_COMPONENTS} ) if( NOT ${CMAKE_FIND_PACKAGE_NAME}_${_component}_FOUND AND ${CMAKE_FIND_PACKAGE_NAME}_FIND_REQUIRED ) message( SEND_ERROR "ectrans was not build with support for COMPONENT ${_component}" ) endif() endforeach() ectrans-1.8.0/cmake/ectrans_find_cuda.cmake0000664000175000017500000000155115174631767021103 0ustar alastairalastairmacro( ectrans_find_cuda ) if(NOT DEFINED CMAKE_CUDA_ARCHITECTURES) ecbuild_info("CMAKE_CUDA_ARCHITECTURES not defined, using 80") set(CMAKE_CUDA_ARCHITECTURES 80) endif() check_language(CUDA) if ( NOT CMAKE_CUDA_COMPILER ) set( HAVE_CUDA 0 ) else() enable_language(CUDA) set( HAVE_CUDA 1 ) find_package( CUDAToolkit ) if( NOT TARGET CUDA::cublas ) ecbuild_info("No target CUDA::cublas") set( HAVE_CUDA 0 ) endif() if( NOT TARGET CUDA::cufft ) ecbuild_info("No target CUDA::cufft") set( HAVE_CUDA 1 ) endif() ecbuild_info( "cuda arch : [${CMAKE_CUDA_ARCHITECTURES}]" ) ecbuild_info( "cublas : [${CUDA_cublas_LIBRARY}]" ) ecbuild_info( "cufft : [${CUDA_cufft_LIBRARY}]" ) endif() endmacro() ectrans-1.8.0/cmake/ectrans_find_hip.cmake0000664000175000017500000001117715174631767020754 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. macro( ectrans_find_hip ) # This macro finds all HIP related libraries, if found, HAVE_HIP=1 cmake_minimum_required( VERSION 3.24 FATAL_ERROR ) set( options "" ) set( single_value_args REQUIRED ) set( multi_value_args "" ) cmake_parse_arguments( _PAR "${options}" "${single_value_args}" "${multi_value_args}" ${_FIRST_ARG} ${ARGN} ) set(HIP_REQUIRED "") if( _PAR_REQUIRED ) set(HIP_REQUIRED "REQUIRED" ) endif() set(HAVE_HIP 1) # Setup ROCM_PATH if (NOT DEFINED ROCM_PATH ) find_path(ROCM_PATH hip ENV{ROCM_DIR} ENV{ROCM_PATH} ENV{HIP_PATH} ${HIP_PATH}/.. ${HIP_ROOT_DIR}/../ ${ROCM_ROOT_DIR} /opt/rocm) endif() ecbuild_info("ROCM path: ${ROCM_PATH}") # Update CMAKE_PREFIX_PATH to make sure all the configs that hip depends on are found. set(CMAKE_PREFIX_PATH "${CMAKE_PREFIX_PATH};${ROCM_PATH}") set(HAVE_HIP 1) include(CheckLanguage) check_language(HIP) ecbuild_add_option( FEATURE HIP_LANGUAGE DEFAULT ON CONDITION CMAKE_HIP_COMPILER ) if( HAVE_HIP_LANGUAGE ) if(NOT CMAKE_HIP_COMPILER) if( _PAR_REQUIRED ) ecbuild_error("HIP compiler not found") else() ecbuild_info("HIP compiler not found: HAVE_HIP=0") set(HAVE_HIP 0) endif() else() enable_language(HIP) ecbuild_info("HIP compiler found: ${CMAKE_HIP_COMPILER}") ecbuild_info("HIP target architecture: ${CMAKE_HIP_ARCHITECTURES}") endif() # Find HIP libraries find_package(hip REQUIRED CONFIG) if( NOT hip_FOUND ) ecbuild_info("hip libraries not found: HAVE_HIP=0") set( HAVE_HIP 0 ) endif() ecbuild_info("HIP version: ${hip_VERSION}") else() ecbuild_info("HIP sources will be compiled with C++ compiler with added flags") ecbuild_info("HIP target architecture: ${CMAKE_HIP_ARCHITECTURES}") enable_language(CXX) set(CMAKE_MODULE_PATH $ENV{HIP_ROOT}/cmake ${CMAKE_MODULE_PATH}) find_package(HIP) if ( NOT HIP_FOUND ) ecbuild_info("HIP not found: HAVE_HIP=0") set( HAVE_HIP 0) endif() ecbuild_info("HIP version: ${HIP_VERSION}") endif() if( HAVE_HIP ) find_package(hipblas CONFIG ${HIP_REQUIRED}) if( NOT hipblas_FOUND ) ecbuild_info("hipblas libraries not found: HAVE_HIP=0") set( HAVE_HIP 0 ) endif() find_package(hipfft CONFIG ${HIP_REQUIRED}) if( NOT hipfft_FOUND ) ecbuild_info("hipfft libraries not found: HAVE_HIP=0") set( HAVE_HIP 0 ) endif() find_package(rocblas CONFIG ${HIP_REQUIRED}) if( NOT rocblas_FOUND ) ecbuild_info("rocblas libraries not found: HAVE_HIP=0") set( HAVE_HIP 0 ) endif() find_package(rocfft CONFIG ${HIP_REQUIRED}) if( NOT rocfft_FOUND ) ecbuild_info("rocfft libraries not found: HAVE_HIP=0") set( HAVE_HIP 0 ) endif() if( HAVE_HIP ) list( APPEND ECTRANS_GPU_HIP_LIBRARIES ${hipblas_LIBRARIES} ${hipfft_LIBRARIES}) list( APPEND ECTRANS_GPU_HIP_LIBRARIES ${rocblas_LIBRARIES} ${rocfft_LIBRARIES}) endif() endif() ecbuild_info("HIP libraries: ${ECTRANS_GPU_HIP_LIBRARIES}") endmacro() macro( ectrans_declare_hip_sources ) set( options QUIET ) set( single_value_args "" ) set( multi_value_args SOURCES SOURCES_GLOB ) cmake_parse_arguments( _PAR "${options}" "${single_value_args}" "${multi_value_args}" ${_FIRST_ARG} ${ARGN} ) set( source_files ${_PAR_SOURCES} ) if( _PAR_SOURCES_GLOB ) ecbuild_list_add_pattern( LIST source_files GLOB ${_PAR_SOURCES_GLOB} QUIET ) endif() if( HAVE_HIP_LANGUAGE ) if(NOT _PAR_QUIET) ecbuild_info("Applying HIP language to ${source_files}") endif() set_source_files_properties( ${source_files} PROPERTIES LANGUAGE HIP ) else() if(NOT _PAR_QUIET) ecbuild_info("Applying HIP flags to ${source_files}") endif() set_source_files_properties( ${source_files} PROPERTIES LANGUAGE CXX ) set( _flags "-x hip" ) if( CMAKE_HIP_FLAGS ) set( _flags "${_flags} ${CMAKE_HIP_FLAGS}" ) endif() if( CMAKE_HIP_ARCHITECTURES ) set( _flags "${_flags} --offload-arch=${CMAKE_HIP_ARCHITECTURES}" ) endif() set_source_files_properties( ${source_files} PROPERTIES COMPILE_FLAGS "${_flags}" ) endif() endmacro() ectrans-1.8.0/cmake/ectrans_find_lapack.cmake0000664000175000017500000000264115174631767021423 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. macro( ectrans_find_lapack ) # This macro sets the LAPACK_LIBRARIES variable # IF MKL is preferred, unless ENABLE_MKL=OFF if( HAVE_MKL ) set( LAPACK_LIBRARIES ${MKL_LIBRARIES} ) else() # Following libsci code should disappear soon, with more recent cmake versions (needs more investigation) if( DEFINED ENV{CRAY_LIBSCI_DIR} ) set( _cray_libsci_loaded $ENV{CRAY_LIBSCI_DIR} ) elseif( DEFINED ENV{CRAY_LIBSCI_BASE_DIR} ) set( _cray_libsci_loaded $ENV{CRAY_LIBSCI_BASE_DIR} ) endif() if( _cray_libsci_loaded ) set( _CRAY_PRGENV $ENV{PE_ENV} ) string( TOLOWER "${_CRAY_PRGENV}" _cray_prgenv ) set( LAPACK_LIBRARIES sci_${_cray_prgenv} ) ecbuild_debug( "LAPACK found, already loaded as part of Cray's libsci" ) else() ecbuild_find_package( NAME LAPACK REQUIRED ) if( TARGET lapack ) ecbuild_debug( "LAPACK found as CMake target lapack" ) set( LAPACK_LIBRARIES lapack ) endif() endif() endif() ecbuild_debug_var( LAPACK_LIBRARIES ) endmacro() ectrans-1.8.0/cmake/project_summary.cmake0000664000175000017500000000366315174631767020701 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. ecbuild_info( "build type : [${CMAKE_BUILD_TYPE}]" ) set( Fortran_flags_str "Fortran flags" ) set( C_flags_str "C flags " ) set( CXX_flags_str "C++ flags " ) set( HIP_flags_str "HIP flags " ) string( TOUPPER ${PROJECT_NAME} PNAME ) foreach( lang Fortran C CXX HIP ) set( flags "${CMAKE_${lang}_FLAGS} ${CMAKE_${lang}_FLAGS_${CMAKE_BUILD_TYPE_CAPS}} ${${PNAME}_${lang}_FLAGS} ${${PNAME}_${lang}_FLAGS_${CMAKE_BUILD_TYPE_CAPS}}" ) string(REGEX REPLACE "[ ]+" " " flags ${flags}) string(STRIP "${flags}" flags) ecbuild_info( "${${lang}_flags_str} : [${flags}]" ) endforeach() ecbuild_info( "OMP" ) foreach( lang Fortran ) ecbuild_info( " OpenMP_${lang}_FLAGS : [${OpenMP_${lang}_FLAGS}]" ) endforeach() ecbuild_info( "ACC" ) foreach( lang Fortran ) ecbuild_info( " OpenACC_${lang}_FLAGS : [${OpenACC_${lang}_FLAGS}]" ) endforeach() ecbuild_info( "BLAS/LAPACK" ) if( HAVE_SINGLE_PRECISION AND HAVE_DOUBLE_PRECISION AND ECTRANS_CRAYHACK_DOUBLE_PRECISION_WITHOUT_MKL ) ecbuild_info( " trans_dp : [${LAPACK_dp}]" ) ecbuild_info( " trans_sp : [${LAPACK_sp}]" ) else() ecbuild_info( " LAPACK_LIBRARIES : [${LAPACK_LIBRARIES}]" ) endif() ecbuild_info( "FFTW" ) ecbuild_info( " FFTW_LIBRARIES : [${FFTW_LIBRARIES}]" ) if( CMAKE_TEST_LAUNCHER ) ecbuild_info( "CMAKE_TEST_LAUNCHER : [${CMAKE_TEST_LAUNCHER}]" ) endif() ecbuild_info( "---------------------------------------------------------" ) ectrans-1.8.0/cmake/ectrans_compile_options.cmake0000664000175000017500000000745415174631767022402 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. # Flag to tell compiler that Fortran side has no program # Needed if linking a C executable against some Fortran objects with some compilers # Not needed for most set( NO_FORTRAN_MAIN_FLAG "" ) if( CMAKE_Fortran_COMPILER_ID MATCHES "XL" ) ecbuild_add_fortran_flags("-qextname -qnobindcextname") elseif( CMAKE_Fortran_COMPILER_ID MATCHES "GNU" ) # gfortran 10 has become stricter with argument matching if( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10 ) ecbuild_add_fortran_flags("-fallow-argument-mismatch") endif() elseif( CMAKE_Fortran_COMPILER_ID MATCHES "NVHPC" ) ecbuild_add_fortran_flags("-Mlarge_arrays") # should really be part of configuration, or ecbuild default? ecbuild_add_fortran_flags("-traceback" BUILD DEBUG ) ecbuild_add_fortran_flags("-fast" BUILD RELEASE ) ecbuild_add_fortran_flags("-gopt -fast" BUILD RELWITHDEBINFO ) set( NO_FORTRAN_MAIN_FLAG "-Mnomain") elseif( CMAKE_Fortran_COMPILER_ID MATCHES "Cray" ) ecbuild_add_fortran_flags("-hnomessage=878") # A module named ... has already been directly or indirectly use associated into this scope ecbuild_add_fortran_flags("-hnomessage=867") # Module ... has no public objects declared in the module, therefore nothing can be use associated from the module. ecbuild_add_fortran_flags("-M7256") # An OpenMP parallel construct in a target region is limited to a single thread. elseif( CMAKE_Fortran_COMPILER_ID MATCHES "IntelLLVM" ) ecbuild_add_fortran_flags("-march=core-avx2 -no-fma" BUILD BIT) ecbuild_add_fortran_flags("-fp-model precise -fp-speculation=safe") set( NO_FORTRAN_MAIN_FLAG "-nofor-main" ) elseif( CMAKE_Fortran_COMPILER_ID MATCHES "Intel" ) ecbuild_add_fortran_flags("-march=core-avx2 -no-fma" BUILD BIT) ecbuild_add_fortran_flags("-fast-transcendentals -fp-model precise -fp-speculation=safe") set( NO_FORTRAN_MAIN_FLAG "-nofor-main") endif() if( NOT DEFINED ECTRANS_HAVE_CONTIGUOUS_ISSUE ) if( CMAKE_Fortran_COMPILER_ID MATCHES "Intel" ) if( CMAKE_Fortran_COMPILER_VERSION VERSION_LESS_EQUAL 19) set( ECTRANS_HAVE_CONTIGUOUS_ISSUE True ) endif() elseif( CMAKE_Fortran_COMPILER_ID MATCHES "GNU" ) # GCC versions 9.2, 11.2, 12.2, 13.3, 14.2 are all known to have an issue with `contiguous` # Logic below is defensive and assumes future versions of gcc are likely to also have the issue if( CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 9 ) set( ECTRANS_HAVE_CONTIGUOUS_ISSUE True ) endif() endif() endif() macro( ectrans_add_compile_options ) set( options NOFAIL ) set( single_value_args FLAGS) set( multi_value_args SOURCES ) cmake_parse_arguments( _PAR "${options}" "${single_value_args}" "${multi_value_args}" ${_FIRST_ARG} ${ARGN} ) if(_PAR_UNPARSED_ARGUMENTS) ecbuild_critical("Unknown keywords given to ectrans_add_compile_flags(): \"${_PAR_UNPARSED_ARGUMENTS}\"") endif() if(NOT _PAR_SOURCES) ecbuild_critical("SOURCES keyword missing to ectrans_add_compile_flags()") endif() if(NOT _PAR_FLAGS) ecbuild_critical("FLAGS keyword missing to ectrans_add_compile_flags()") endif() foreach( _file ${_PAR_SOURCES} ) ecbuild_warn("Adding custom compile flags for file ${_file} : [${_PAR_FLAGS}]") if( NOT EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/${_file} AND NOT _PAR_NOFAIL) ecbuild_error("${_file} does not exist") endif() set_source_files_properties( ${_file} PROPERTIES COMPILE_FLAGS "${_PAR_FLAGS}" ) endforeach() endmacro() ectrans-1.8.0/AUTHORS0000664000175000017500000000125315174631767014435 0ustar alastairalastairAuthors and Contributors ======================== - P. Courtier (ECMWF) - W. Deconinck (ECMWF) - D. Degrauwe (RMI) - D. Dent (ECMWF) - P. Dueben (ECMWF) - R. El Khatib (Meteo France) - D. Giard (Meteo France) - J. Hague (ECMWF) - M. Hamrud (ECMWF) - S. Hatfield (ECMWF) - M. Hortal (ECMWF) - L. Isaksen (ECMWF) - P. Marguinaud (Meteo France) - O. Marsden (ECMWF) - L. Mosimann (NVIDIA) - G. Mozdzynski (ECMWF) - A. Mueller (ECMWF) - G. Radnoti (ECMWF) - D. Salmond (ECMWF) - Y. Seity (Meteo France) - F. Vana (ECMWF) - N. Wedi (ECMWF) - T. Wilhelmsson (ECMWF) - K. Yessad (Meteo France) If you have contributed to this project, please add your name in the above alphabetical list. ectrans-1.8.0/MANIFEST.in0000664000175000017500000000005415174631767015121 0ustar alastairalastairrecursive-include cmake exclude MANIFEST.in ectrans-1.8.0/CMakeLists.txt0000664000175000017500000001657315174631767016140 0ustar alastairalastair# (C) Copyright 2020- ECMWF. # # 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. cmake_minimum_required( VERSION 3.25 FATAL_ERROR ) find_package( ecbuild 3.8 REQUIRED HINTS ${CMAKE_CURRENT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR}/../ecbuild ) project( ectrans LANGUAGES C CXX Fortran ) include( ectrans_macros ) # CMake 3.29 adds CMAKE_TEST_LAUNCHER defined either as CMake variable or environment. # This launcher is a semi-colon-separted list of arguments that is used to launch serial tasks, # and can be defined during the CMake configuration. # This is e.g. required for GPU tests that need access to slurm resources: # export CMAKE_TEST_LAUNCHER="srun;-n;1" # To run the tests then: # salloc -q --gpus-per-task=1 -n ctest # Before cmake 3.29 this could only be achieved with CMAKE_CROSSCOMPILING_EMULATOR. # This next snippet ensures forward compatibility if( ${CMAKE_VERSION} VERSION_LESS "3.29" ) if( DEFINED CMAKE_TEST_LAUNCHER ) set(CMAKE_CROSSCOMPILING_EMULATOR ${CMAKE_TEST_LAUNCHER}) elseif(DEFINED ENV{CMAKE_TEST_LAUNCHER}) set(CMAKE_CROSSCOMPILING_EMULATOR $ENV{CMAKE_TEST_LAUNCHER}) endif() endif() if( CMAKE_CROSSCOMPILING_EMULATOR ) set( CMAKE_TEST_LAUNCHER ${CMAKE_CROSSCOMPILING_EMULATOR} ) endif() set(CMAKE_CXX_STANDARD 17) ecbuild_enable_fortran( REQUIRED NO_MODULE_DIRECTORY ) ### Find (optional) dependencies ecbuild_find_package( NAME fiat VERSION 1.3.0 REQUIRED ) # Inherit MPI feature from FIAT (if you don't want MPI, rebuild FIAT with ENABLE_MPI=OFF) set( HAVE_MPI ${fiat_HAVE_MPI} ) set( ectrans_HAVE_MPI ${HAVE_MPI} ) # also needed as more specific alias to HAVE_MPI ecbuild_add_option( FEATURE OMP DEFAULT ON DESCRIPTION "Support for OpenMP shared memory parallelism" REQUIRED_PACKAGES "OpenMP COMPONENTS Fortran" ) ecbuild_add_option( FEATURE ACC DEFAULT OFF DESCRIPTION "Support for using GPUs with OpenACC" REQUIRED_PACKAGES "OpenACC COMPONENTS Fortran" ) ecbuild_add_option( FEATURE DOUBLE_PRECISION DEFAULT ON DESCRIPTION "Support for Double Precision" ) ecbuild_add_option( FEATURE SINGLE_PRECISION DEFAULT ON DESCRIPTION "Support for Single Precision" ) # Check DOUBLE_PRECISION or SINGLE_PRECISION is enabled, and if not, abort if( (NOT HAVE_DOUBLE_PRECISION) AND (NOT HAVE_SINGLE_PRECISION) ) ecbuild_critical("Please enable one or both of the DOUBLE_PRECISION and SINGLE_PRECISION features") endif() if( HAVE_SINGLE_PRECISION ) set( single "single" ) endif() set( HAVE_dp ${HAVE_DOUBLE_PRECISION} ) set( HAVE_sp ${HAVE_SINGLE_PRECISION} ) ecbuild_add_option( FEATURE CPU DEFAULT ON DESCRIPTION "Compile CPU version of ectrans" ) ecbuild_add_option( FEATURE MKL DESCRIPTION "Use MKL for BLAS and/or FFTW" DEFAULT ON REQUIRED_PACKAGES "MKL QUIET" CONDITION HAVE_CPU ) if( NOT HAVE_MKL ) option( FFTW_ENABLE_MKL OFF ) endif() if( HAVE_CPU ) ecbuild_find_package( NAME FFTW REQUIRED COMPONENTS double ${single} ) endif() ecbuild_add_option( FEATURE TRANSI DEFAULT ON DESCRIPTION "Compile TransI C-interface to trans" CONDITION HAVE_DOUBLE_PRECISION AND HAVE_CPU ) # Search for available GPU runtimes, searching for CUDA first and, if not found, # attempt to find HIP if( ECTRANS_ENABLE_GPU OR (NOT DEFINED ECTRANS_ENABLE_GPU AND ENABLE_GPU)) set(HAVE_CUDA 0) set(HAVE_HIP 0) ectrans_find_cuda() # sets "HAVE_CUDA" if( NOT HAVE_CUDA ) ectrans_find_hip() # sets "HAVE_HIP" endif() endif() ecbuild_add_option( FEATURE GPU DEFAULT OFF DESCRIPTION "Compile GPU version of ectrans (Requires OpenACC or sufficient OpenMP offloading support)" CONDITION (HAVE_HIP OR HAVE_CUDA) AND (HAVE_ACC OR HAVE_OMP) ) # Check CPU or GPU is enabled, and if not, abort if( (NOT HAVE_CPU) AND (NOT HAVE_GPU) ) ecbuild_critical("Please enable one or both of the CPU and GPU features") endif() if( HAVE_GPU ) if( HAVE_ACC ) set( GPU_OFFLOAD "ACC" ) elseif( HAVE_OMP ) set( GPU_OFFLOAD "OMP" ) else() ecbuild_error("Could not enable GPU as OMP or ACC were not enabled") endif() endif() ecbuild_add_option( FEATURE CUTLASS DEFAULT OFF CONDITION HAVE_GPU AND HAVE_CUDA AND CMAKE_Fortran_COMPILER_ID MATCHES "NVHPC" DESCRIPTION "Support for Cutlass BLAS operations" REQUIRED_PACKAGES "NvidiaCutlass VERSION 2.11" ) # following also needs cuda arch sm80 to be effective ecbuild_add_option( FEATURE CUTLASS_3XTF32 DEFAULT ON CONDITION HAVE_SINGLE_PRECISION AND HAVE_CUTLASS DESCRIPTION "Support for 3xTF32 with Cutlass (>= 2.8) and CUDA_ARCHITECTURES >= 80" ) ecbuild_add_option( FEATURE GPU_AWARE_MPI DEFAULT ON CONDITION HAVE_GPU AND HAVE_MPI REQUIRED_PACKAGES "MPI COMPONENTS Fortran" DESCRIPTION "Enable GPU-aware MPI" ) ecbuild_add_option( FEATURE GPU_GRAPHS_GEMM DEFAULT ON CONDITION HAVE_GPU DESCRIPTION "Enable graph-based optimisation of Legendre transform GEMM kernel" ) ecbuild_add_option( FEATURE GPU_GRAPHS_FFT DEFAULT ON CONDITION HAVE_GPU DESCRIPTION "Enable graph-based optimisation of FFT kernels" ) if( BUILD_SHARED_LIBS ) set( GPU_STATIC_DEFAULT OFF ) else() set( GPU_STATIC_DEFAULT ON ) endif() ecbuild_add_option( FEATURE GPU_STATIC DEFAULT ${GPU_STATIC_DEFAULT} DESCRIPTION "Compile GPU library as static library" CONDITION HAVE_GPU ) ecbuild_add_option( FEATURE ETRANS DEFAULT OFF DESCRIPTION "Include Limited-Area-Model Transforms" ) # Note: ETRANS GPU does not support OpenMP yet or FFT graphs yet set( HAVE_ETRANS_GPU 0 ) if( HAVE_ETRANS AND HAVE_GPU ) if( HAVE_ACC AND NOT HAVE_GRAPHS_FFT ) set( HAVE_ETRANS_GPU 1 ) else() ecbuild_warn( "ETRANS and GPU features requested, but ACC and GRAPHS_FFT also requested." "The GPU version of etrans only supports OpenACC at the moment, with FFT graphs disabled." ) endif() endif() ecbuild_add_option( FEATURE ECTRANS4PY DEFAULT OFF CONDITION HAVE_ETRANS AND HAVE_DOUBLE_PRECISION DESCRIPTION "Compile ectrans4py interface routines for python binding w/ ctypesForFortran" ) ectrans_find_lapack() ### Add sources include( ectrans_compile_options ) add_subdirectory( src ) ### Add tests if( HAVE_TESTS ) add_subdirectory( tests ) endif() ### Export if( BUILD_SHARED_LIBS ) set( PACKAGE_REQUIRES_PRIVATE_DEPENDENCIES 0 ) else() set( PACKAGE_REQUIRES_PRIVATE_DEPENDENCIES 1 ) endif() ecbuild_install_project( NAME ${PROJECT_NAME} ) ecbuild_print_summary() ectrans-1.8.0/.github/0000775000175000017500000000000015174631767014724 5ustar alastairalastairectrans-1.8.0/.github/workflows/0000775000175000017500000000000015174631767016761 5ustar alastairalastairectrans-1.8.0/.github/workflows/build.yml0000664000175000017500000001706215174631767020611 0ustar alastairalastairname: build # Controls when the action will run on: # Trigger the workflow on all pushes, except on tag creation push: branches: - '**' tags-ignore: - '**' # Trigger the workflow on all pull requests pull_request: ~ # Allow workflow to be dispatched on demand workflow_dispatch: ~ env: ECTRANS_TOOLS: ${{ github.workspace }}/.github/tools CTEST_PARALLEL_LEVEL: 1 CACHE_SUFFIX: v1 # Increase to force new cache to be created jobs: ci: name: ci strategy: fail-fast: false # false: try to complete all jobs matrix: build_type: [Release,Debug] name: - linux gnu-13 - linux clang-18 - linux nvhpc-25.1 - linux intel-classic - linux intel-modern - macos include: - name: linux gnu-13 os: ubuntu-24.04 compiler: gnu-13 compiler_cc: gcc-13 compiler_cxx: g++-13 compiler_fc: gfortran-13 ctest_options: -E memory caching: true - name: linux clang-18 os: ubuntu-24.04 compiler: clang-18 compiler_cc: clang-18 compiler_cxx: clang++-18 compiler_fc: gfortran-14 ctest_options: -E memory caching: true - name: linux nvhpc-25.1 os: ubuntu-24.04 compiler: nvhpc-25.1 compiler_cc: nvc compiler_cxx: nvc++ compiler_fc: nvfortran cmake_options: -DCMAKE_CXX_FLAGS=--diag_suppress177 -DMPI_ARGS=--oversubscribe ctest_options: -E memory caching: false - name : linux intel-classic os: ubuntu-22.04 compiler: intel-classic compiler_cc: icc compiler_cxx: icpc compiler_fc: ifort caching: true - name : linux intel-modern os: ubuntu-24.04 compiler: intel-modern compiler_cc: icx compiler_cxx: icpx compiler_fc: ifx cmake_options: -DCMAKE_Fortran_FLAGS=-heap-arrays python-version: '3.11' caching: true - name: macos # Xcode compiler requires empty environment variables, so we pass null (~) here os: macos-15 compiler: clang-17 compiler_cc: ~ compiler_cxx: ~ compiler_fc: gfortran-13 cmake_options: -DMPI_ARGS=--oversubscribe caching: true runs-on: ${{ matrix.os }} steps: - name: Checkout Repository uses: actions/checkout@v2 - name: Environment run: | echo "DEPS_DIR=${{ runner.temp }}/deps" >> $GITHUB_ENV echo "CC=${{ matrix.compiler_cc }}" >> $GITHUB_ENV echo "CXX=${{ matrix.compiler_cxx }}" >> $GITHUB_ENV echo "FC=${{ matrix.compiler_fc }}" >> $GITHUB_ENV if [[ "${{ matrix.os }}" =~ macos ]]; then brew install ninja else sudo apt-get update sudo apt-get install ninja-build fi printenv - name: Cache Dependencies # There seems to be a problem with cached NVHPC dependencies, leading to SIGILL perhaps due to slightly different architectures if: matrix.caching id: deps-cache uses: pat-s/always-upload-cache@v2.1.5 with: path: ${{ env.DEPS_DIR }} key: deps-${{ matrix.os }}-${{ matrix.compiler }}-${{ matrix.build_type }}-${{ env.CACHE_SUFFIX }} # Free up disk space for nvhpc - name: Free Disk Space (Ubuntu) uses: jlumbroso/free-disk-space@main if: contains( matrix.compiler, 'nvhpc' ) continue-on-error: true with: # this might remove tools that are actually needed, # if set to "true" but frees about 6 GB tool-cache: false # all of these default to true, but feel free to set to # "false" if necessary for your workflow android: true dotnet: true haskell: true large-packages: true docker-images: true swap-storage: true - name: Install NVHPC compiler if: contains( matrix.compiler, 'nvhpc' ) shell: bash -eux {0} run: | ${ECTRANS_TOOLS}/install-nvhpc.sh --prefix /opt/nvhpc source /opt/nvhpc/env.sh echo "${NVHPC_DIR}/compilers/bin" >> $GITHUB_PATH [ -z ${MPI_HOME+x} ] || echo "MPI_HOME=${MPI_HOME}" >> $GITHUB_ENV - name: Download Intel compiler if: contains( matrix.compiler, 'intel' ) run: | wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB sudo add-apt-repository "deb https://apt.repos.intel.com/oneapi all main" - name: Install Intel classic compiler if: contains( matrix.compiler, 'intel-classic' ) run: | version=2023.2.0 sudo apt-get update sudo apt-get install \ intel-oneapi-compiler-fortran-$version \ intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-$version \ intel-oneapi-mpi-devel-2021.10.0 \ intel-oneapi-mkl-$version source /opt/intel/oneapi/setvars.sh printenv >> $GITHUB_ENV echo "CACHE_SUFFIX=$CC-$($CC -dumpversion)" >> $GITHUB_ENV - name: Install Intel modern compiler if: contains( matrix.compiler, 'intel-modern' ) run: | sudo apt-get update sudo apt-get install intel-hpckit source /opt/intel/oneapi/setvars.sh printenv >> $GITHUB_ENV echo "CACHE_SUFFIX=$CC-$($CC -dumpversion)" >> $GITHUB_ENV - name: Install MPI shell: bash -eux {0} run: | FCFLAGS=-fPIC CFLAGS=-fPIC FFLAGS=-fPIC ${ECTRANS_TOOLS}/install-mpi.sh --mpi openmpi --prefix ${DEPS_DIR}/openmpi [ -f ${DEPS_DIR}/openmpi/env.sh ] && source ${DEPS_DIR}/openmpi/env.sh [ -z ${MPI_HOME+x} ] || echo "MPI_HOME=${MPI_HOME}" >> $GITHUB_ENV - name: Install FFTW shell: bash -eux {0} run: | ${ECTRANS_TOOLS}/install-fftw.sh --version 3.3.10 --with-single --prefix ${DEPS_DIR}/fftw echo "FFTW_ROOT=${DEPS_DIR}/fftw" >> $GITHUB_ENV - name: Install OpenBLAS shell: bash -eux {0} run: ${ECTRANS_TOOLS}/install-openblas.sh - name: Set Build & Test Environment run: | # Add mpirun to path for testing [ -z ${MPI_HOME+x} ] || echo "${MPI_HOME}/bin" >> $GITHUB_PATH - name: Build & Test id: build-test uses: ecmwf-actions/build-package@v2 with: self_coverage: false force_build: true cache_suffix: "${{ matrix.build_type }}-${{ env.CACHE_SUFFIX }}" recreate_cache: ${{ matrix.caching == false }} dependencies: | ecmwf/ecbuild ecmwf-ifs/fiat dependency_branch: develop dependency_cmake_options: | ecmwf-ifs/fiat: "-G Ninja -DCMAKE_BUILD_TYPE=${{ matrix.build_type }} -DENABLE_TESTS=OFF -DENABLE_MPI=ON" cmake_options: "-G Ninja -DCMAKE_BUILD_TYPE=${{ matrix.build_type }} ${{ matrix.cmake_options }} -DENABLE_MPI=ON -DENABLE_FFTW=ON -DENABLE_ETRANS=ON" ctest_options: "${{ matrix.ctest_options }}" - name: Verify tools run: | export PATH=${{ steps.build-test.outputs.bin_path }}:$PATH echo "+ ectrans --info" ectrans --info # - name: Codecov Upload # if: steps.build-test.outputs.coverage_file # uses: codecov/codecov-action@v2 # with: # files: ${{ steps.build-test.outputs.coverage_file }} ectrans-1.8.0/.github/workflows/build-ectrans4py.yml0000664000175000017500000000703215174631767022677 0ustar alastairalastairname: build-ectrans4py # Controls when the action will run on: # Trigger the workflow on all pushes, except on tag creation push: branches: - '**' tags-ignore: - '**' # Trigger the workflow on all pull requests pull_request: ~ # Allow workflow to be dispatched on demand workflow_dispatch: ~ env: ECTRANS_TOOLS: ${{ github.workspace }}/ectrans/.github/tools CTEST_PARALLEL_LEVEL: 1 CACHE_SUFFIX: v1 # Increase to force new cache to be created jobs: ci: name: ci strategy: fail-fast: false # false: try to complete all jobs matrix: build_type: [Release,Debug] name: - linux gnu-13 - macos include: - name: linux gnu-13 os: ubuntu-24.04 compiler: gnu-13 compiler_cc: gcc-13 compiler_cxx: g++-13 compiler_fc: gfortran-13 ctest_options: -E memory caching: true - name: macos # Xcode compiler requires empty environment variables, so we pass null (~) here os: macos-15 compiler: clang-17 compiler_cc: ~ compiler_cxx: ~ compiler_fc: gfortran-13 caching: true runs-on: ${{ matrix.os }} steps: - name: Checkout ecBuild uses: actions/checkout@v4 with: repository: ecmwf/ecbuild path: ecbuild - name: Checkout FIAT uses: actions/checkout@v4 with: repository: ecmwf-ifs/fiat path: fiat - name: Checkout ecTrans uses: actions/checkout@v4 with: path: ectrans - name: Environment run: | echo "DEPS_DIR=${{ runner.temp }}/deps" >> $GITHUB_ENV echo "CC=${{ matrix.compiler_cc }}" >> $GITHUB_ENV echo "CXX=${{ matrix.compiler_cxx }}" >> $GITHUB_ENV echo "FC=${{ matrix.compiler_fc }}" >> $GITHUB_ENV if [[ "${{ matrix.os }}" =~ macos ]]; then brew install ninja else sudo apt-get update sudo apt-get install ninja-build fi printenv - name: Install FIAT run: | cmake -B $GITHUB_WORKSPACE/fiat/build -S $GITHUB_WORKSPACE/fiat cmake --build $GITHUB_WORKSPACE/fiat/build echo "fiat_ROOT=$GITHUB_WORKSPACE/fiat/build" >> $GITHUB_ENV - name: Install FFTW shell: bash -eux {0} run: | ${ECTRANS_TOOLS}/install-fftw.sh --version 3.3.10 --with-single --prefix ${DEPS_DIR}/fftw echo "FFTW_ROOT=${DEPS_DIR}/fftw" >> $GITHUB_ENV - name: Install OpenBLAS shell: bash -eux {0} run: ${ECTRANS_TOOLS}/install-openblas.sh - name: Build ectrans4py run: | python3 -m venv venv . venv/bin/activate pip install build python -m build --wheel ectrans -o $GITHUB_WORKSPACE pip install ectrans4py* - name: Check ectrans4py version run: | . venv/bin/activate cd $GITHUB_WORKSPACE/ectrans ectrans4py_version=`python -c "import ectrans4py; print(ectrans4py.__version__)"` ectrans_version=`cat VERSION` if [ "$ectrans4py_version" != "$ectrans_version" ]; then echo "ectrans4py and ectrans versions don't match" echo "ectrans4py_version = $ectrans4py_version" echo "ectrans_version = $ectrans_version" exit 1 fi - name: Test ectrans4py run: | . venv/bin/activate cd $GITHUB_WORKSPACE/ectrans/tests/test_ectrans4py pip install pytest python -m pytest ectrans-1.8.0/.github/workflows/label-public-pr.yml0000664000175000017500000000035415174631767022460 0ustar alastairalastair# Manage labels of pull requests that originate from forks name: label-public-pr on: pull_request_target: types: [opened, synchronize] jobs: label: uses: ecmwf-actions/reusable-workflows/.github/workflows/label-pr.yml@v2ectrans-1.8.0/.github/workflows/build-hpc.yml0000664000175000017500000001461015174631767021355 0ustar alastairalastairname: build-hpc # Controls when the action will run on: # Trigger the workflow on all pushes to main and develop, except on tag creation push: branches: - main - develop tags-ignore: - '**' # Trigger the workflow on all pull requests pull_request: ~ # Allow workflow to be dispatched on demand workflow_dispatch: ~ # Trigger after public PR approved for CI pull_request_target: types: [labeled] env: ECTRANS_TOOLS: ${{ github.workspace }}/.github/tools CTEST_PARALLEL_LEVEL: 1 CACHE_SUFFIX: v1 # Increase to force new cache to be created jobs: ci-hpc: name: ci-hpc if: ${{ !github.event.pull_request.head.repo.fork && github.event.action != 'labeled' || github.event.label.name == 'approved-for-ci' }} strategy: fail-fast: false # false: try to complete all jobs matrix: name: - ac-gpu nvhpc - lumi-g cce include: - name: ac-gpu nvhpc site: ac-batch troika_user_secret: HPC_CI_SSH_USER sbatch_options: | #SBATCH --time=00:30:00 #SBATCH --nodes=1 #SBATCH --ntasks=4 #SBATCH --cpus-per-task=32 #SBATCH --gpus-per-task=1 #SBATCH --mem=200G #SBATCH --qos=dg modules: - cmake - ninja - prgenv/nvidia - nvidia/24.5 - hpcx-openmpi/2.19.0-cuda - fftw env_vars: - CMAKE_GENERATOR=Ninja - name: lumi-g cce site: lumi troika_user_secret: LUMI_CI_SSH_USER account_secret: LUMI_CI_PROJECT sbatch_options: | #SBATCH --time=01:10:00 #SBATCH --nodes=1 #SBATCH --ntasks-per-node=8 #SBATCH --gpus-per-task=1 #SBATCH --partition=standard-g #SBATCH --account={0} modules: - LUMI/25.03 - cce/19.0.0 - craype-accel-amd-gfx90a - rocm/6.3.4 - cray-fftw - buildtools output_dir: /scratch/{0}/github-actions/ectrans/${{ github.run_id }}/${{ github.run_attempt }} workdir: /scratch/{0}/github-actions/ectrans/${{ github.run_id }}/${{ github.run_attempt }} env_vars: - ROCFFT_RTC_CACHE_PATH=$PWD/../../rocfft_kernel_cache.db - MPICH_GPU_SUPPORT_ENABLED=1 - MPICH_SMP_SINGLE_COPY_MODE=NONE - CMAKE_BUILD_PARALLEL_LEVEL=1 runs-on: [self-hosted, linux, hpc] env: GH_TOKEN: ${{ github.token }} steps: - uses: ecmwf-actions/reusable-workflows/ci-hpc-generic@v2 with: site: ${{ matrix.site }} troika_user: ${{ secrets[matrix.troika_user_secret] }} sbatch_options: ${{ format(matrix.sbatch_options, secrets[matrix.account_secret]) }} output_dir: ${{ format(matrix.output_dir, secrets[matrix.account_secret]) || '' }} workdir: ${{ format(matrix.workdir, secrets[matrix.account_secret]) || '' }} template_data: | site: ${{ matrix.site }} cmake_options: - -DENABLE_MPI=ON - -DENABLE_GPU=ON - -DENABLE_ETRANS=ON - -DENABLE_GPU_GRAPHS_GEMM=OFF - -DENABLE_GPU_GRAPHS_FFT=OFF ctest_options: ${{ matrix.ctest_options || '' }} dependencies: ecmwf/ecbuild: version: develop ecmwf-ifs/fiat: version: develop cmake_options: - -DENABLE_MPI=ON template: | REPO=${{ github.event.pull_request.head.repo.full_name || github.repository }} SHA=${{ github.event.pull_request.head.sha || github.sha }} # Cleanup function cleanup() { {% for name in dependencies.keys() %} rm -r {{name}} {% endfor %} rm -r $REPO rm -r build } error_trap() { cleanup echo "Finished: FAILURE" exit 1 } trap error_trap ERR {% for module in "${{ join(matrix.modules, ',') }}".split(',') %} module load {{module}} {% endfor %} {% for var in "${{ join(matrix.env_vars, ',') }}".split(',') %} export {{var}} {% endfor %} export CMAKE_TEST_LAUNCHER="srun;-n;1" export DR_HOOK_ASSERT_MPI_INITIALIZED=0 BASEDIR=$PWD # Fetch dependencies {% for name, options in dependencies.items() %} mkdir -p {{name}} pushd {{name}} git init git remote add origin ${{ github.server_url }}/{{name}} git fetch origin {{options['version']}} git reset --hard FETCH_HEAD popd {% endfor %} # Fetch ecTrans mkdir -p $REPO pushd $REPO git init git remote add origin ${{ github.server_url }}/$REPO git fetch origin $SHA git reset --hard FETCH_HEAD popd # Build dependencies {% for name, options in dependencies.items() %} pushd {{name}} cmake -S . -B build \ {% for name in dependencies %} {% set org, proj = name.split('/') %} -D{{proj}}_ROOT=$BASEDIR/{{name}}/installation \ {% endfor %} -DCMAKE_TOOLCHAIN_FILE=$BASEDIR/$REPO/.github/arch/{{ site }}.cmake \ {{ options['cmake_options']|join(' ') }} cmake --build build cmake --install build --prefix installation popd {% endfor %} # Build ecTrans cmake -S $REPO -B build \ {% for name in dependencies %} {% set org, proj = name.split('/') %} -D{{proj}}_ROOT=$BASEDIR/{{name}}/installation \ {% endfor %} -DCMAKE_TOOLCHAIN_FILE=$BASEDIR/$REPO/.github/arch/{{ site }}.cmake \ {{ cmake_options|join(' ') }} cmake --build build ctest --test-dir build --output-on-failure {{ ctest_options }} cleanup ectrans-1.8.0/.github/tools/0000775000175000017500000000000015174631767016064 5ustar alastairalastairectrans-1.8.0/.github/tools/install-fftw.sh0000775000175000017500000000455515174631767021046 0ustar alastairalastair#! /usr/bin/env bash # (C) Copyright 2013 ECMWF. # # 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. set +x set -e -o pipefail SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" export PATH=$SCRIPTDIR:$PATH # Some defaults for the arguments PREFIX=$(pwd)/install fftw_version=3.3.10 fftw_configure="--enable-shared" fftw_with_single=false while [ $# != 0 ]; do case "$1" in "--prefix") PREFIX="$2"; shift ;; "--version") fftw_version="$2"; shift ;; "--with-single") fftw_with_single=true; ;; *) echo "Unrecognized argument '$1'" exit 1 ;; esac shift done echo "Installing FFTW version ${fftw_version}" fftw_installed=${PREFIX}/fftw-${fftw_version}-installed if [[ -f "${fftw_installed}" ]]; then echo "FFTW ${fftw_version} is already installed at ${PREFIX}" exit fi os=$(uname) case "$os" in Darwin) brew ls --versions fftw || brew install fftw exit ;; *) ;; esac if [ -z "${TMPDIR+x}" ]; then TMPDIR=${HOME}/tmp fi mkdir -p ${TMPDIR}/downloads fftw_tarball_url=http://www.fftw.org/fftw-${fftw_version}.tar.gz fftw_tarball=$TMPDIR/downloads/fftw-${fftw_version}.tar.gz fftw_dir=$TMPDIR/downloads/fftw-${fftw_version} echo "+ curl -L ${fftw_tarball_url} > ${fftw_tarball}" curl -L ${fftw_tarball_url} > ${fftw_tarball} echo "+ tar xzf ${fftw_tarball} -C ${TMPDIR}/downloads" tar xzf ${fftw_tarball} -C ${TMPDIR}/downloads echo "+ cd ${fftw_dir}" cd ${fftw_dir} echo "+ ./configure --prefix=${PREFIX} ${fftw_configure}" ./configure --prefix=${PREFIX} ${fftw_configure} echo "+ make -j8" make -j8 echo "+ make install" make install if $fftw_with_single; then # Now again in single precision make clean echo "+ ./configure --prefix=${PREFIX} ${fftw_configure} --enable-float" ./configure --prefix=${PREFIX} ${fftw_configure} --enable-float echo "+ make -j8" make -j8 echo "+ make install" make install fi echo "+ rm -rf \${fftw_tarball} \${fftw_dir}" rm -rf ${fftw_tarball} ${fftw_dir} echo "+ touch ${fftw_installed}" touch ${fftw_installed} ectrans-1.8.0/.github/tools/reduce-output.sh0000775000175000017500000000231515174631767021231 0ustar alastairalastair#!/bin/bash # (C) Copyright 2013 ECMWF. # # 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. # Abort on Error set -e PING_SLEEP=30s dump_output() { echo " ++ Tailing the last 100 lines of output from $BUILD_OUTPUT" tail -100 $BUILD_OUTPUT } error_handler() { echo ERROR: An error was encountered with the build. kill $PING_LOOP_PID dump_output exit 1 } # If an error occurs, run our error handler to output a tail of the build trap 'error_handler' ERR # Set up a repeating loop to display some output regularly. bash -c "while true; do sleep $PING_SLEEP; echo \" ++ \$(date) - running ... \"; done" & PING_LOOP_PID=$! BUILD_OUTPUT=build-$PING_LOOP_PID.out touch $BUILD_OUTPUT echo " + $@" echo " ++ Output redirected to $BUILD_OUTPUT" $@ >> $BUILD_OUTPUT 2>&1 # The build finished without returning an error so dump a tail of the output dump_output # nicely terminate the ping output loop kill $PING_LOOP_PID ectrans-1.8.0/.github/tools/install-openblas.sh0000775000175000017500000000146515174631767021700 0ustar alastairalastair#! /usr/bin/env bash # (C) Copyright 2025 ECMWF. # # 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. set +x set -e -o pipefail SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" export PATH=$SCRIPTDIR:$PATH os=$(uname) case "$os" in Darwin) echo "Installing OpenBLAS via brew" brew ls --versions openblas || brew install openblas exit ;; Linux) echo "Installing OpenBLAS via apt-get" sudo apt-get install libblas-dev liblapack-dev exit ;; *) ;; esacectrans-1.8.0/.github/tools/install-mpi.sh0000775000175000017500000001155615174631767020664 0ustar alastairalastair#!/bin/bash set +x set -e -o pipefail SCRIPTDIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" export PATH=$SCRIPTDIR:$PATH # Some defaults for the arguments PREFIX=$(pwd)/${MPI} mpi_override=false MPI=openmpi while [ $# != 0 ]; do case "$1" in "--prefix") PREFIX="$2"; shift ;; "--override") mpi_override=true; ;; "--version") mpi_version="$2"; shift ;; "--mpi") MPI="$2"; shift ;; *) echo "Unrecognized argument '$1'" exit 1 ;; esac shift done os=$(uname) OMPIVER=4.1.1 MPICHVER=3.4.2 if [ ! -z ${mpi_version+x} ]; then if [[ "${MPI}" =~ [Oo][Pp][Ee][Nn]\-?[Mm][Pp][Ii] ]]; then OMPIVER=${mpi_version} fi if [[ "${MPI}" =~ [Mm][Pp][Ii][Cc][Hh] ]]; then MPICHVER=${mpi_version} fi fi mkdir -p ${PREFIX} touch ${PREFIX}/env.sh MPI_INSTALLED=false case "$os" in Darwin) case "$MPI" in mpich) brew ls --versions mpich || brew install mpich ;; openmpi) brew ls --versions openmpi || brew install openmpi echo "localhost slots=72" >> $(brew --prefix)/etc/openmpi-default-hostfile # workaround for open-mpi/omp#7516 echo "setting the mca gds to hash..." echo "gds = hash" >> $(brew --prefix)/etc/pmix-mca-params.conf # workaround for open-mpi/ompi#5798 echo "setting the mca btl_vader_backing_directory to /tmp..." echo "btl_vader_backing_directory = /tmp" >> $(brew --prefix)/etc/openmpi-mca-params.conf ;; *) echo "Unknown MPI implementation: $MPI" exit 1 ;; esac ;; Linux) if [ -n "${MPI_HOME}" ]; then echo "MPI is already installed at MPI_HOME=${MPI_HOME}." echo "Not taking any action." exit 0 fi case "$MPI" in mpich) if [ -f ${PREFIX}/include/mpi.h ]; then echo "${PREFIX}/include/mpi.h found" fi if [ -f ${PREFIX}/lib/libmpich.so ]; then echo "${PREFIX}/lib/libmpich.so found -- nothing to build." else echo "Downloading mpich source..." wget http://www.mpich.org/static/downloads/${MPICHVER}/mpich-${MPICHVER}.tar.gz tar xfz mpich-${MPICHVER}.tar.gz rm mpich-${MPICHVER}.tar.gz echo "Configuring and building mpich..." cd mpich-${MPICHVER} unset F90 unset F90FLAGS ${SCRIPTDIR}/reduce-output.sh ./configure \ --prefix=${PREFIX} \ --enable-static=false \ --enable-alloca=true \ --enable-threads=single \ --enable-fortran=yes \ --enable-fast=all \ --enable-g=none \ --enable-timing=none ${SCRIPTDIR}/reduce-output.sh make -j48 ${SCRIPTDIR}/reduce-output.sh make install MPI_INSTALLED=true cd - rm -rf mpich-${MPICHVER} fi ;; openmpi) if [ -f ${PREFIX}/include/mpi.h ]; then echo "openmpi/include/mpi.h found." fi if [ -f ${PREFIX}/lib/libmpi.so ] || [ -f ${PREFIX}/lib64/libmpi.so ]; then echo "libmpi.so found -- nothing to build." else echo "Downloading openmpi source..." wget --no-check-certificate https://www.open-mpi.org/software/ompi/v4.1/downloads/openmpi-$OMPIVER.tar.gz tar -zxf openmpi-$OMPIVER.tar.gz rm openmpi-$OMPIVER.tar.gz echo "Configuring and building openmpi..." cd openmpi-$OMPIVER ${SCRIPTDIR}/reduce-output.sh ./configure --prefix=${PREFIX} ${SCRIPTDIR}/reduce-output.sh make -j4 ${SCRIPTDIR}/reduce-output.sh make install MPI_INSTALLED=true echo "localhost slots=72" >> ${PREFIX}/etc/openmpi-default-hostfile cd - rm -rf openmpi-$OMPIVER fi ;; *) echo "Unknown MPI implementation: $MPI" exit 1 ;; esac ;; *) echo "Unknown operating system: $os" exit 1 ;; esac if ${MPI_INSTALLED} ; then cat > ${PREFIX}/env.sh << EOF export MPI_HOME=${PREFIX} export PATH=\${MPI_HOME}/bin:\${PATH} EOF echo "Please source ${PREFIX}/env.sh, containing:" cat ${PREFIX}/env.sh fi ectrans-1.8.0/.github/tools/install-nvhpc.sh0000775000175000017500000000613515174631767021212 0ustar alastairalastair#!/bin/sh # Install NVHPC # https://github.com/nemequ/pgi-travis # # Originally written for Squash by # Evan Nemerson. For documentation, bug reports, support requests, # etc. please use . # # To the extent possible under law, the author(s) of this script have # waived all copyright and related or neighboring rights to this work. # See for # details. version=25.1 TEMPORARY_FILES="${TMPDIR:-/tmp}" export NVHPC_INSTALL_DIR=$(pwd)/nvhpc-install export NVHPC_SILENT=true while [ $# != 0 ]; do case "$1" in "--prefix") export NVHPC_INSTALL_DIR="$2"; shift ;; "--tmpdir") TEMPORARY_FILES="$2"; shift ;; "--verbose") export NVHPC_SILENT=false; ;; "--version") version="$2"; shift ;; *) echo "Unrecognized argument '$1'" exit 1 ;; esac shift done case "$(uname -m)" in x86_64|ppc64le|aarch64) ;; *) echo "Unknown architecture: $(uname -m)" >&2 exit 1 ;; esac if [ -d "${NVHPC_INSTALL_DIR}" ]; then if [[ $(find "${NVHPC_INSTALL_DIR}" -name "nvc" | wc -l) == 1 ]]; then echo "NVHPC already installed at ${NVHPC_INSTALL_DIR}" exit fi fi # Example download URL for version 21.9 # https://developer.download.nvidia.com/hpc-sdk/21.9/nvhpc_2020_219_Linux_x86_64_cuda_11.0.tar.gz ver="$(echo $version | tr -d . )" URL=$(curl -s "https://developer.nvidia.com/nvidia-hpc-sdk-$ver-downloads" | grep -oP "https://developer.download.nvidia.com/hpc-sdk/([0-9]{2}\.[0-9]+)/nvhpc_([0-9]{4})_([0-9]+)_Linux_$(uname -m)_cuda_([0-9\.]+).tar.gz" | sort | tail -1) FOLDER="$(basename "$(echo "${URL}" | grep -oP '[^/]+$')" .tar.gz)" if [ ! -d "${TEMPORARY_FILES}/${FOLDER}" ]; then echo "Downloading ${TEMPORARY_FILES}/${FOLDER} from URL [${URL}]" mkdir -p ${TEMPORARY_FILES} curl --location \ --user-agent "pgi-travis (https://github.com/nemequ/pgi-travis)" \ "${URL}" | tar zx -C "${TEMPORARY_FILES}" else echo "Download already present in ${TEMPORARY_FILES}/${FOLDER}" fi echo "+ ${TEMPORARY_FILES}/${FOLDER}/install" "${TEMPORARY_FILES}/${FOLDER}/install" #comment out to cleanup #rm -rf "${TEMPORARY_FILES}/${FOLDER}" NVHPC_VERSION=$(basename "${NVHPC_INSTALL_DIR}"/Linux_$(uname -m)/*.*/) # Use gcc which is available in PATH ${NVHPC_INSTALL_DIR}/Linux_$(uname -m)/${NVHPC_VERSION}/compilers/bin/makelocalrc \ -x ${NVHPC_INSTALL_DIR}/Linux_$(uname -m)/${NVHPC_VERSION}/compilers/bin \ -gcc $(which gcc) \ -gpp $(which g++) \ -g77 $(which gfortran) cat > ${NVHPC_INSTALL_DIR}/env.sh << EOF ### Variables export NVHPC_INSTALL_DIR=${NVHPC_INSTALL_DIR} export NVHPC_VERSION=${NVHPC_VERSION} export NVHPC_DIR=\${NVHPC_INSTALL_DIR}/Linux_$(uname -m)/\${NVHPC_VERSION} ### Compilers export PATH=\${NVHPC_DIR}/compilers/bin:\${PATH} export NVHPC_LIBRARY_PATH=\${NVHPC_DIR}/compilers/lib export LD_LIBRARY_PATH=\${NVHPC_LIBRARY_PATH} ### MPI export MPI_HOME=\${NVHPC_DIR}/comm_libs/mpi export PATH=\${MPI_HOME}/bin:\${PATH} EOF cat ${NVHPC_INSTALL_DIR}/env.sh ectrans-1.8.0/.github/arch/0000775000175000017500000000000015174631767015641 5ustar alastairalastairectrans-1.8.0/.github/arch/lumi.cmake0000664000175000017500000000120015174631767017602 0ustar alastairalastair# (C) Copyright 2026- ECMWF. # # 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. # CSC LUMI-G cluster, with AMD MI250X GPUs set( OpenMP_C_FLAGS "-fopenmp" ) set( OpenMP_C_LIB_NAMES craymp ) set( OpenMP_Fortran_LIB_NAMES craymp crayacc ) set( OpenMP_craymp_LIBRARY craymp ) set( OpenMP_crayacc_LIBRARY crayacc_amdgpu ) set( ENABLE_OMP ON ) ectrans-1.8.0/.github/arch/ac-batch.cmake0000664000175000017500000000070315174631767020305 0ustar alastairalastair# (C) Copyright 2026- ECMWF. # # 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. # ECMWF/HPC2020 AC complex, with Nvidia A100 GPUs set( ENABLE_ACC ON )