libsim Versione 7.2.6
|
◆ compile_sl()Produce a vector of list of variables usefull for produce your request.
Definizione alla linea 798 del file alchimia.F03. 799! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
800! authors:
801! Davide Cesari <dcesari@arpa.emr.it>
802! Paolo Patruno <ppatruno@arpa.emr.it>
803
804! This program is free software; you can redistribute it and/or
805! modify it under the terms of the GNU General Public License as
806! published by the Free Software Foundation; either version 2 of
807! the License, or (at your option) any later version.
808
809! This program is distributed in the hope that it will be useful,
810! but WITHOUT ANY WARRANTY; without even the implied warranty of
811! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
812! GNU General Public License for more details.
813
814! You should have received a copy of the GNU General Public License
815! along with this program. If not, see <http://www.gnu.org/licenses/>.
816#include "config.h"
817
818!> \defgroup alchimia Libsim package, alchimia library.
819!! Generate new variabile using function libraries
820
821!> This module defines objects and methods for generating
822!! derivative variables.
823!!\ingroup alchimia
825
831
832IMPLICIT NONE
833
834integer, parameter :: nmaxb=100
835
836abstract interface
837 subroutine elabora(mybin,mybout,bin,bout,in,out)
838 import
839 CHARACTER(len=10),intent(in) :: mybin(:) !< vector table B WMO input in user's data
840 CHARACTER(len=10),intent(in) :: mybout(:) !< vector table B WMO output in user's data
841 CHARACTER(len=10),intent(in) :: bin(:) !< vector table B WMO input used by function
842 CHARACTER(len=10),intent(in) :: bout(:) !< vector table B WMO output used by function
843 real, intent(in) :: in(:,:)
844 real, intent(out) :: out(:,:)
845 end subroutine elabora
846end interface
847
848type fnds
849 CHARACTER(len=50) :: name=cmiss
850 CHARACTER(len=10),allocatable :: bin(:) !< table B WMO
851 CHARACTER(len=10),allocatable :: bout(:) !< table B WMO
852 integer :: priority
853 integer :: order
854 procedure(elabora) ,nopass, pointer :: fn
855end type fnds
856
857!> Vector of function to transform the input to alchimia module
859 integer :: nin = imiss
860 integer :: nout = imiss
861 type(fnds),allocatable :: fnds(:)
863
864!> shoplist are list of variables
866 CHARACTER(len=10),allocatable :: bvar(:) !< table B WMO
868
869!> Vector of shoplists that are list of variables
871 type(shoplist),allocatable :: shoplist(:)
873
874!>Check missing values for fnds
876 module procedure c_e_fn
877end interface
878
879interface OPERATOR (==)
880 module procedure equal_fn
881end interface
882
883interface init
884 module procedure fn_init
885end interface
886
887!> show on the screen the fnds and fndsv structure
889 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
890end interface
891
892!> Delete fndsv
894 module procedure fnv_delete
895end interface
896
897!> Do the real work to transform the input data to the output
899 module procedure makev
900end interface
901
902
903!!$#define ARRAYOF_ORIGTYPE TYPE(fnds)
904!!$#define ARRAYOF_TYPE arrayof_fnds
905!!$#define ARRAYOF_ORIGEQ 0
906!!$#include "arrayof_pre.F90"
907!!$! from arrayof
908!!$PUBLIC insert, append, remove, packarray
909!!$PUBLIC insert_unique, append_unique
910private
913
914contains
915
916!> Register the copy function to be able to copy input variables to output if requested
917subroutine register_copy(vfn,bin)
918
919 type(fndsv),intent(inout) :: vfn !< vector of function descriptors into register
920 CHARACTER(len=10),intent(in) :: bin(:) !< vector table B WMO input in user's data
921 integer :: i
922
923 do i=1, size(bin)
924 call fnregister(vfn,alchimia_copy_def(bin(i)))
925 end do
926
927end subroutine register_copy
928
929subroutine alchimia_copy(mybin,mybout,bin,bout,in,out)
930 CHARACTER(len=10),intent(in) :: mybin(:) !< vector table B WMO input in user's data
931 CHARACTER(len=10),intent(in) :: mybout(:) !< vector table B WMO output in user's data
932 CHARACTER(len=10),intent(in) :: bin(:) !< vector table B WMO input used by function
933 CHARACTER(len=10),intent(in) :: bout(:) !< vector table B WMO output used by function
934 real, intent(in) :: in(:,:) !< input data array
935 real, intent(out) :: out(:,:) !< output data array
936
937 out(:,index_c(mybout,bout(1)))=in(:,index_c(mybin,bin(1)))
938
939end subroutine alchimia_copy
940
941type(fnds) function alchimia_copy_def(bvar)
942 CHARACTER(len=10),intent(in) :: bvar
943
944 call init(alchimia_copy_def,"copy"//bvar,&
945 [character(len=10) :: bvar],&
946 [character(len=10) :: bvar],0,func=alchimia_copy)
947end function alchimia_copy_def
948
949!> Inizialize a function object
950subroutine fn_init(fn,name,bin,bout,priority,order,func)
951type(fnds),intent(inout) :: fn !< function object to create
952CHARACTER(len=*),optional :: name !< description of function
953CHARACTER(len=*),optional :: bin(:) !< standard table B descriptor for input parameters
954CHARACTER(len=*),optional :: bout(:) !< standard table B descriptor for output parameters
955integer,optional :: priority !< relative priority for choise from functions with same output
956integer,optional :: order !< order to execute functions
957procedure(elabora),optional :: func !< function with the abstract interface
958
959call optio(name,fn%name)
960
961if (present(bin)) then
962 fn%bin=bin
963else
964 allocate(fn%bin(1))
965 fn%bin=cmiss
966end if
967
968if (present(bout)) then
969 fn%bout=bout
970else
971 allocate(fn%bout(1))
972 fn%bout=cmiss
973end if
974
975call optio(priority,fn%priority)
976call optio(order,fn%order)
977
978if (present(func)) then
979 fn%fn => func
980else
981 fn%fn => null()
982end if
983
984end subroutine fn_init
985
986
987!> Delete a vector of function object reinizializing it
988elemental subroutine fnv_delete(fnv)
989type(fndsv),intent(inout) :: fnv
990type(fndsv) :: fn
991
992fnv=fn
993
994end subroutine fnv_delete
995
996!> Register a function object in the vector function object.
997!! If called without argoments allocate vectors to (0)
998!! if order is present force the order of added function
999subroutine fnregister(vfn,fn,order)
1000
1001type(fndsv),intent(inout) :: vfn !< vector function object to ampliate
1002type(fnds),intent(in),optional :: fn !< function object to add
1003integer,optional :: order !< order to execute the new added function object
1004
1005integer :: nfn
1006type(fndsv) :: vfntmp
1007
1008if (.not. allocated(vfn%fnds))then
1009 allocate(vfn%fnds(0))
1010 vfn%nin=0
1011 vfn%nout=0
1012end if
1013
1014if (present(fn))then
1015
1016 if (firsttrue(vfn%fnds == fn) /= 0) return
1017 nfn=size(vfn%fnds)
1018
1019 allocate(vfntmp%fnds(nfn+1))
1020
1021 vfntmp%fnds(:nfn)=vfn%fnds
1022
1023 call move_alloc(from=vfntmp%fnds ,to=vfn%fnds)
1024
1025 vfn%fnds(nfn+1)=fn
1026 if (present(order)) vfn%fnds(nfn+1)%order = order
1027
1028 vfn%nin=vfn%nin+size(fn%bin)
1029 vfn%nout=vfn%nout+size(fn%bout)
1030
1031 CALL l4f_log(l4f_debug, 'fnregister: adding function object '//trim(fn%name)//' ; nout '//t2c(vfn%nout))
1032
1033end if
1034
1035end subroutine fnregister
1036
1037!> Check missing function objects
1038elemental logical function c_e_fn(fn)
1039type(fnds),intent(in) :: fn !< function object to check
1040
1041c_e_fn= c_e(fn%name)
1042
1043end function c_e_fn
1044
1045elemental logical function equal_fn(this,that)
1046type(fnds),intent(in) :: this,that
1047
1048equal_fn= this%name == that%name
1049
1050end function equal_fn
1051
1052
1053!> Display shopping lists on screen
1054subroutine sl_display(sl)
1055type(shoplists),intent(in) :: sl !< shopping lists to display
1056
1057integer :: i
1058
1059do i = 1, size(sl%shoplist)
1060 print *,"shopping list : ",i
1061 print *,"varlist : ",sl%shoplist(i)%bvar
1062 print *,""
1063end do
1064
1065end subroutine sl_display
1066
1067
1068!> Display function objects on screen
1069subroutine fn_display(fn)
1070type(fnds),intent(in) :: fn !< function object to display
1072 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
1074 print *,"function : ",fn%name," order :",fn%order
1076 print *,"function : ",fn%name," priority :",fn%priority
1077else
1078 print *,"function : ",fn%name
1079end if
1082print *,""
1083
1084end subroutine fn_display
1085
1086!> Display vector function objects on screen
1087subroutine fnv_display(fnv)
1088type(fndsv),intent(in) :: fnv !< vector function object to display
1089integer :: i
1090
1091if (.not. allocated(fnv%fnds))return
1092
1093print *,"-------------------------------------------------"
1094print *, "Here the function tree:"
1097end do
1098print *,"-------------------------------------------------"
1099end subroutine fnv_display
1100
1101
1102
1103!> Display vector function objects on screen selected by order
1104subroutine fnv_display_byorder(fnv,order)
1105type(fndsv),intent(in) :: fnv !< vector function object to display
1106integer,intent(in) :: order !< level for recursice search of functions
1107
1108integer :: i
1109
1110print *,"-------------------------------------------------"
1111print *, "Here the function tree for order: ",order
1113 if (fnv%fnds(i)%order == order ) then
1115 end if
1116end do
1117print *,"-------------------------------------------------"
1118end subroutine fnv_display_byorder
1119
1120
1121
1122!> Display vector function objects on screen
1123subroutine vfnv_display(vfnv)
1124type(fndsv),intent(in) :: vfnv(:) !< vector function object to display
1125integer :: i
1126
1127print *,">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
1128do i = 1, size(vfnv)
1129 print*,">> Function tree number:",i
1131end do
1132print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
1133end subroutine vfnv_display
1134
1135
1136
1137!> This function like a oracle say you how to abtain what you want.
1138!! Starting from desciption of input and output and a vector of available functions
1139!! provide to you the road to execute for make the output
1140recursive logical function oracle(mybin,mybout,vfn,myvfn,recurse) result(stat)
1141type(fndsv),intent(in) :: vfn !< vector function object available
1142character(len=*),intent(in) :: mybin(:) !< standard table B description of input
1143character(len=*),intent(in) :: mybout(:) !< standard table B description of output
1144type(fndsv),intent(out) :: myvfn !< vector function object that solve the problem
1145logical,optional :: recurse !< set to .true. when called in recurse
1146
1147type(fndsv),save :: usefullfn,maybefn
1148
1149!!$type(arrayof_fnds) :: tmp
1150!!$tmp = arrayof_fnds_new()
1151!!$append(tmp,myfn(1))
1152!!$CALL packarray(tmp)
1153!!$print *,tmp%array
1154
1155integer :: i,j,k,iin,iout
1156logical :: allfoundout, foundout, somefoundin, foundin
1157integer,save :: order,num
1158character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
1159
1160
1161! delete only on the main call
1162if (.not. optio_log(recurse)) then
1163 CALL l4f_log(l4f_debug, "oracle: delete and register")
1167 call fnregister(maybefn)
1168 call fnregister(usefullfn)
1169 call fnregister(myvfn)
1170 order=0
1171end if
1172
1173CALL l4f_log(l4f_debug, "oracle: order "//t2c(order))
1174newbin=cmiss
1175newbin(:size(mybin))=mybin
1176newbout=cmiss
1177newbout(:size(mybin))=mybin
1178
1179! order is level to put functions
1180order=order+1
1181somefoundin = .false.
1182num=count(c_e(maybefn%fnds))
1183tmpbin=cmiss
1184
1185!search for functions starting from input
1187 foundin = .true.
1189 if (.not. any(vfn%fnds(i)%bin(j) == newbin)) foundin = .false.
1190!!$ print *,"compare: ",vfn(i)%bin(j)
1191!!$ print *,"with: ",mybin
1192 end do
1193 if (foundin) then
1194 CALL l4f_log(l4f_debug, "oracle: register "//trim(vfn%fnds(i)%name))
1195 call fnregister(maybefn,vfn%fnds(i),order)
1196 do k=1,size(vfn%fnds(i)%bout)
1197 tmpbin(firsttrue(.not. c_e(tmpbin)))=vfn%fnds(i)%bout(k)
1198 newbout(firsttrue(.not. c_e(newbout)))=vfn%fnds(i)%bout(k)
1199 end do
1200 somefoundin = .true.
1201 end if
1202end do
1203
1205 newbin(firsttrue(.not. c_e(newbin)))=tmpbin(i)
1206end do
1207
1208! here bin and bout are bigger (newbin, newbout)
1209! by the output of applicable functions
1210
1211
1212!check if we can work anymore
1213stat = .false.
1214if (.not. somefoundin) return
1216
1217!check if we have finish
1218allfoundout = .true.
1220 foundout = .false.
1222 if (newbout(j) == mybout(i)) foundout = .true.
1223 end do
1224 if (.not. foundout) allfoundout = .false.
1225end do
1226
1227
1228! ok, all is done
1229if (allfoundout) then
1230
1231!!$ print *, "intermediate"
1232!!$ do i =1,size(maybefn)
1233!!$ if (c_e(maybefn(i))) print *,maybefn(i)
1234!!$ end do
1235
1236 ! remove dry branch
1237 newbout=cmiss
1238 newbout(:size(mybout))=mybout
1239 tmpbin=cmiss
1240
1242 if (maybefn%fnds(i)%order /= order) then
1243 CALL l4f_log(l4f_debug, "oracle: change order "//t2c(maybefn%fnds(i)%order))
1244 order=maybefn%fnds(i)%order
1245 iin=count(c_e(tmpbin))
1246 iout=count(c_e(newbout))
1247 newbout(iout+1:iout+iin)=tmpbin(:iin)
1248 tmpbin=cmiss
1249 end if
1250
1251 !print *,"search:",newbout(:firsttrue(.not. c_e(newbout)))
1252
1253 foundout = .false.
1255 if (any(maybefn%fnds(i)%bout(:) == newbout(j))) foundout = .true.
1256 end do
1257 if (foundout) then
1258 CALL l4f_log(l4f_debug, "oracle: other register "// trim(maybefn%fnds(i)%name))
1259 call fnregister(myvfn,maybefn%fnds(i),order)
1261 tmpbin(firsttrue(.not. c_e(tmpbin)))=maybefn%fnds(i)%bin(k)
1262 end do
1263 end if
1264 end do
1265
1266 stat = .true.
1267
1268else
1269
1270 stat=oracle(newbin,mybout,vfn,myvfn,.true.)
1271
1272end if
1273
1274! delete on exit only on the main call
1275if (.not. optio_log(recurse)) then
1278 order=0
1279end if
1280
1281end function oracle
1282
1283
1284!> This function try to suggest you some road to obtain the variable you want.
1285!! Starting from desciption of output and a vector of available functions
1286!! provide to you some possible starting points.
1287recursive logical function shoppinglist(mybout,vfn,myvfn, copy, recurse) result(stat)
1288type(fndsv),intent(in) :: vfn !< vector function object available
1289character(len=*),intent(in) :: mybout(:) !< standard table B description of output
1290type(fndsv),intent(inout) :: myvfn !< vector function object that solve the problem
1291logical,intent(in),optional :: copy !< if .true. the copy functions are localy added to vfn (you can have input variable copyed to output)
1292logical,intent(in),optional :: recurse !< set to .true. when called in recurse
1293
1294type(fndsv) :: vfntmp
1295integer :: i,j,k
1296logical :: somefoundout
1297integer,save :: order
1298character(len=10) :: newbout(nmaxb)
1299
1300stat=.true.
1301newbout=cmiss
1302vfntmp=vfn
1303
1304! delete only on the main call
1305if (.not. optio_log(recurse)) then
1306 CALL l4f_log(l4f_debug, "shoppinglist: main call (delete and register)")
1307
1309 call fnregister(myvfn)
1310 order=0
1311 newbout(:size(mybout))=mybout
1312
1313 if (optio_log(copy)) call register_copy(vfntmp,mybout)
1314
1315else
1316
1317 CALL l4f_log(l4f_debug, "shoppinglist: sub call; order:"//t2c(order))
1318
1319 !print*,pack(newbout,c_e(newbout))
1320
1322 !print*,"order:",myvfn%fnds(i)%order, order
1323 if (myvfn%fnds(i)%order == order) then
1324 do k=1,size(myvfn%fnds(i)%bin(:))
1325 newbout(firsttrue(.not. c_e(newbout)))=myvfn%fnds(i)%bin(k)
1326 end do
1327 end if
1328 end do
1329
1330end if
1331
1332!print*,pack(newbout,c_e(newbout))
1333
1334! order is level to put functions
1335order=order+1
1336somefoundout = .false.
1337
1338CALL l4f_log(l4f_debug, "shoppinglist: order "//t2c(order))
1339
1340!search for functions outputing my output
1342 !call display(vfntmp%fnds(i))
1344 if (any(vfntmp%fnds(i)%bout(j) == newbout)) then
1345 CALL l4f_log(l4f_debug, "shoppinglist: register "//trim(vfntmp%fnds(i)%name))
1346 call fnregister(myvfn,vfntmp%fnds(i),order)
1347 somefoundout = .true.
1348 end if
1349 end do
1350end do
1351
1352!check if we can work anymore
1353if (.not. somefoundout) return
1354
1355stat=shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy), recurse=.true.)
1356
1357! delete on exit only on the main call
1358if (.not. optio_log(recurse)) then
1360 order=0
1361end if
1362
1363end function shoppinglist
1364
1365
1366!> Execute the function to obtain what you have requested to oracle.
1367!! This is a sample only routine for the cousine test case.
1368subroutine makev(mayvfn,mybin,mybout,myin,myout)
1369type(fndsv),intent(inout) :: mayvfn !< vector function object that solve the problem
1370character(len=*),intent(in) :: mybin(:) !< standard table B description of input
1371character(len=*),intent(in) :: mybout(:) !< standard table B description of output
1372real,intent(in) :: myin(:,:) !< data input (ndata,nparameters)
1373real,intent(out) :: myout(:,:)!< data output (ndata,nparameters)
1374integer :: i,j
1375character(len=10) :: newbout(mayvfn%nout)
1376
1377
1378newbout=cmiss
1379do i=1, size(mayvfn%fnds)
1381 do j=1, size(mayvfn%fnds(i)%bout)
1383 if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0) then
1384 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
1385 end if
1386 end if
1387 end do
1388 end if
1389end do
1390
1391do i=size(mayvfn%fnds),1,-1
1393 print *,"name:",mayvfn%fnds(i)%name,"order:",mayvfn%fnds(i)%order
1394
1395 call mayvfn%fnds(i)%fn(mybin,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
1396 !print *,"make",i,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout
1397 end if
1398end do
1399
1400!!$#include "arrayof_post.F90"
1401
1402end subroutine makev
1403
1404
1405
1406
1407!> Produce a vector of list of variables usefull for produce your request.
1408function compile_sl(myvfn)
1409
1410type(shoplists) :: compile_sl
1411type(fndsv),intent(in) :: myvfn !< vector function object that solve the problem
1412
1413integer :: i,j,k,nshoplist,nvar,nfunc,indfunc,indvar
1414CHARACTER(len=10),allocatable :: bvartmp(:)
1415
1416indfunc=0
1417nshoplist=(maxval(myvfn%fnds(:)%order))
1418nshoplist=max(0,nshoplist)
1419allocate (compile_sl%shoplist(nshoplist))
1420
1421nvar=1
1422
1423do i=1,nshoplist
1424 nfunc=count(myvfn%fnds(:)%order==i)
1425 allocate(compile_sl%shoplist(i)%bvar(nvar-1))
1426 if (i > 1) then
1427 compile_sl%shoplist(i)%bvar = compile_sl%shoplist(i-1)%bvar
1428 do j = indfunc+1, indfunc+nfunc
1429 do k = 1, size(myvfn%fnds(j)%bout)
1430 indvar=index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bout(k))
1431 if (indvar > 0) compile_sl%shoplist(i)%bvar(indvar)=cmiss
1432 end do
1433 end do
1434 end if
1435 do j = indfunc+1, indfunc+nfunc
1436 do k = 1, size(myvfn%fnds(j)%bin)
1437 if (index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bin(k)) > 0 ) cycle
1438 allocate(bvartmp(nvar))
1439 bvartmp(:nvar-1)=compile_sl%shoplist(i)%bvar
1440 call move_alloc(from=bvartmp ,to=compile_sl%shoplist(i)%bvar)
1441 compile_sl%shoplist(i)%bvar(nvar)=myvfn%fnds(j)%bin(k)
1442 nvar=nvar+1
1443 end do
1444 end do
1445 indfunc=indfunc+nfunc
1446end do
1447
1448do i=1,nshoplist
1449 compile_sl%shoplist(i)%bvar=pack(compile_sl%shoplist(i)%bvar,c_e(compile_sl%shoplist(i)%bvar))
1450end do
1451
1452end function compile_sl
1453
1455
1456!>\example example_alchimia.f03
1457!!\brief Sample program to demostrate the alchimia module.
1458!!
1459!! This module use cuisine problems to demostrate the capacity of the module.
1460
1461!>\example example_alchimiavg6d.f03
1462!!\brief Sample program to demostrate the alchimia module with volgrid6d.
1463
1464!>\example example_alchimiav7d.f03
1465!! \brief Sample program to demostrate the alchimia module with vol7d.
Do the real work to transform the input data to the output. Definition alchimia.F03:288 This module defines objects and methods for generating derivative variables. Definition alchimia.F03:214 This module defines usefull general purpose function and subroutine. Definition array_utilities.F90:212 Definitions of constants and functions for working with missing values. Definition missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition optional_values.f90:28 Vector of function to transform the input to alchimia module. Definition alchimia.F03:248 |