libsim Versione 7.2.6
|
◆ shoppinglist()
This function try to suggest you some road to obtain the variable you want. Starting from desciption of output and a vector of available functions provide to you some possible starting points.
Definizione alla linea 677 del file alchimia.F03. 678! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
679! authors:
680! Davide Cesari <dcesari@arpa.emr.it>
681! Paolo Patruno <ppatruno@arpa.emr.it>
682
683! This program is free software; you can redistribute it and/or
684! modify it under the terms of the GNU General Public License as
685! published by the Free Software Foundation; either version 2 of
686! the License, or (at your option) any later version.
687
688! This program is distributed in the hope that it will be useful,
689! but WITHOUT ANY WARRANTY; without even the implied warranty of
690! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
691! GNU General Public License for more details.
692
693! You should have received a copy of the GNU General Public License
694! along with this program. If not, see <http://www.gnu.org/licenses/>.
695#include "config.h"
696
697!> \defgroup alchimia Libsim package, alchimia library.
698!! Generate new variabile using function libraries
699
700!> This module defines objects and methods for generating
701!! derivative variables.
702!!\ingroup alchimia
704
710
711IMPLICIT NONE
712
713integer, parameter :: nmaxb=100
714
715abstract interface
716 subroutine elabora(mybin,mybout,bin,bout,in,out)
717 import
718 CHARACTER(len=10),intent(in) :: mybin(:) !< vector table B WMO input in user's data
719 CHARACTER(len=10),intent(in) :: mybout(:) !< vector table B WMO output in user's data
720 CHARACTER(len=10),intent(in) :: bin(:) !< vector table B WMO input used by function
721 CHARACTER(len=10),intent(in) :: bout(:) !< vector table B WMO output used by function
722 real, intent(in) :: in(:,:)
723 real, intent(out) :: out(:,:)
724 end subroutine elabora
725end interface
726
727type fnds
728 CHARACTER(len=50) :: name=cmiss
729 CHARACTER(len=10),allocatable :: bin(:) !< table B WMO
730 CHARACTER(len=10),allocatable :: bout(:) !< table B WMO
731 integer :: priority
732 integer :: order
733 procedure(elabora) ,nopass, pointer :: fn
734end type fnds
735
736!> Vector of function to transform the input to alchimia module
738 integer :: nin = imiss
739 integer :: nout = imiss
740 type(fnds),allocatable :: fnds(:)
742
743!> shoplist are list of variables
745 CHARACTER(len=10),allocatable :: bvar(:) !< table B WMO
747
748!> Vector of shoplists that are list of variables
750 type(shoplist),allocatable :: shoplist(:)
752
753!>Check missing values for fnds
755 module procedure c_e_fn
756end interface
757
758interface OPERATOR (==)
759 module procedure equal_fn
760end interface
761
762interface init
763 module procedure fn_init
764end interface
765
766!> show on the screen the fnds and fndsv structure
768 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
769end interface
770
771!> Delete fndsv
773 module procedure fnv_delete
774end interface
775
776!> Do the real work to transform the input data to the output
778 module procedure makev
779end interface
780
781
782!!$#define ARRAYOF_ORIGTYPE TYPE(fnds)
783!!$#define ARRAYOF_TYPE arrayof_fnds
784!!$#define ARRAYOF_ORIGEQ 0
785!!$#include "arrayof_pre.F90"
786!!$! from arrayof
787!!$PUBLIC insert, append, remove, packarray
788!!$PUBLIC insert_unique, append_unique
789private
792
793contains
794
795!> Register the copy function to be able to copy input variables to output if requested
796subroutine register_copy(vfn,bin)
797
798 type(fndsv),intent(inout) :: vfn !< vector of function descriptors into register
799 CHARACTER(len=10),intent(in) :: bin(:) !< vector table B WMO input in user's data
800 integer :: i
801
802 do i=1, size(bin)
803 call fnregister(vfn,alchimia_copy_def(bin(i)))
804 end do
805
806end subroutine register_copy
807
808subroutine alchimia_copy(mybin,mybout,bin,bout,in,out)
809 CHARACTER(len=10),intent(in) :: mybin(:) !< vector table B WMO input in user's data
810 CHARACTER(len=10),intent(in) :: mybout(:) !< vector table B WMO output in user's data
811 CHARACTER(len=10),intent(in) :: bin(:) !< vector table B WMO input used by function
812 CHARACTER(len=10),intent(in) :: bout(:) !< vector table B WMO output used by function
813 real, intent(in) :: in(:,:) !< input data array
814 real, intent(out) :: out(:,:) !< output data array
815
816 out(:,index_c(mybout,bout(1)))=in(:,index_c(mybin,bin(1)))
817
818end subroutine alchimia_copy
819
820type(fnds) function alchimia_copy_def(bvar)
821 CHARACTER(len=10),intent(in) :: bvar
822
823 call init(alchimia_copy_def,"copy"//bvar,&
824 [character(len=10) :: bvar],&
825 [character(len=10) :: bvar],0,func=alchimia_copy)
826end function alchimia_copy_def
827
828!> Inizialize a function object
829subroutine fn_init(fn,name,bin,bout,priority,order,func)
830type(fnds),intent(inout) :: fn !< function object to create
831CHARACTER(len=*),optional :: name !< description of function
832CHARACTER(len=*),optional :: bin(:) !< standard table B descriptor for input parameters
833CHARACTER(len=*),optional :: bout(:) !< standard table B descriptor for output parameters
834integer,optional :: priority !< relative priority for choise from functions with same output
835integer,optional :: order !< order to execute functions
836procedure(elabora),optional :: func !< function with the abstract interface
837
838call optio(name,fn%name)
839
840if (present(bin)) then
841 fn%bin=bin
842else
843 allocate(fn%bin(1))
844 fn%bin=cmiss
845end if
846
847if (present(bout)) then
848 fn%bout=bout
849else
850 allocate(fn%bout(1))
851 fn%bout=cmiss
852end if
853
854call optio(priority,fn%priority)
855call optio(order,fn%order)
856
857if (present(func)) then
858 fn%fn => func
859else
860 fn%fn => null()
861end if
862
863end subroutine fn_init
864
865
866!> Delete a vector of function object reinizializing it
867elemental subroutine fnv_delete(fnv)
868type(fndsv),intent(inout) :: fnv
869type(fndsv) :: fn
870
871fnv=fn
872
873end subroutine fnv_delete
874
875!> Register a function object in the vector function object.
876!! If called without argoments allocate vectors to (0)
877!! if order is present force the order of added function
878subroutine fnregister(vfn,fn,order)
879
880type(fndsv),intent(inout) :: vfn !< vector function object to ampliate
881type(fnds),intent(in),optional :: fn !< function object to add
882integer,optional :: order !< order to execute the new added function object
883
884integer :: nfn
885type(fndsv) :: vfntmp
886
887if (.not. allocated(vfn%fnds))then
888 allocate(vfn%fnds(0))
889 vfn%nin=0
890 vfn%nout=0
891end if
892
893if (present(fn))then
894
895 if (firsttrue(vfn%fnds == fn) /= 0) return
896 nfn=size(vfn%fnds)
897
898 allocate(vfntmp%fnds(nfn+1))
899
900 vfntmp%fnds(:nfn)=vfn%fnds
901
902 call move_alloc(from=vfntmp%fnds ,to=vfn%fnds)
903
904 vfn%fnds(nfn+1)=fn
905 if (present(order)) vfn%fnds(nfn+1)%order = order
906
907 vfn%nin=vfn%nin+size(fn%bin)
908 vfn%nout=vfn%nout+size(fn%bout)
909
910 CALL l4f_log(l4f_debug, 'fnregister: adding function object '//trim(fn%name)//' ; nout '//t2c(vfn%nout))
911
912end if
913
914end subroutine fnregister
915
916!> Check missing function objects
917elemental logical function c_e_fn(fn)
918type(fnds),intent(in) :: fn !< function object to check
919
920c_e_fn= c_e(fn%name)
921
922end function c_e_fn
923
924elemental logical function equal_fn(this,that)
925type(fnds),intent(in) :: this,that
926
927equal_fn= this%name == that%name
928
929end function equal_fn
930
931
932!> Display shopping lists on screen
933subroutine sl_display(sl)
934type(shoplists),intent(in) :: sl !< shopping lists to display
935
936integer :: i
937
938do i = 1, size(sl%shoplist)
939 print *,"shopping list : ",i
940 print *,"varlist : ",sl%shoplist(i)%bvar
941 print *,""
942end do
943
944end subroutine sl_display
945
946
947!> Display function objects on screen
948subroutine fn_display(fn)
949type(fnds),intent(in) :: fn !< function object to display
951 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
953 print *,"function : ",fn%name," order :",fn%order
955 print *,"function : ",fn%name," priority :",fn%priority
956else
957 print *,"function : ",fn%name
958end if
961print *,""
962
963end subroutine fn_display
964
965!> Display vector function objects on screen
966subroutine fnv_display(fnv)
967type(fndsv),intent(in) :: fnv !< vector function object to display
968integer :: i
969
970if (.not. allocated(fnv%fnds))return
971
972print *,"-------------------------------------------------"
973print *, "Here the function tree:"
976end do
977print *,"-------------------------------------------------"
978end subroutine fnv_display
979
980
981
982!> Display vector function objects on screen selected by order
983subroutine fnv_display_byorder(fnv,order)
984type(fndsv),intent(in) :: fnv !< vector function object to display
985integer,intent(in) :: order !< level for recursice search of functions
986
987integer :: i
988
989print *,"-------------------------------------------------"
990print *, "Here the function tree for order: ",order
992 if (fnv%fnds(i)%order == order ) then
994 end if
995end do
996print *,"-------------------------------------------------"
997end subroutine fnv_display_byorder
998
999
1000
1001!> Display vector function objects on screen
1002subroutine vfnv_display(vfnv)
1003type(fndsv),intent(in) :: vfnv(:) !< vector function object to display
1004integer :: i
1005
1006print *,">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
1007do i = 1, size(vfnv)
1008 print*,">> Function tree number:",i
1010end do
1011print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
1012end subroutine vfnv_display
1013
1014
1015
1016!> This function like a oracle say you how to abtain what you want.
1017!! Starting from desciption of input and output and a vector of available functions
1018!! provide to you the road to execute for make the output
1019recursive logical function oracle(mybin,mybout,vfn,myvfn,recurse) result(stat)
1020type(fndsv),intent(in) :: vfn !< vector function object available
1021character(len=*),intent(in) :: mybin(:) !< standard table B description of input
1022character(len=*),intent(in) :: mybout(:) !< standard table B description of output
1023type(fndsv),intent(out) :: myvfn !< vector function object that solve the problem
1024logical,optional :: recurse !< set to .true. when called in recurse
1025
1026type(fndsv),save :: usefullfn,maybefn
1027
1028!!$type(arrayof_fnds) :: tmp
1029!!$tmp = arrayof_fnds_new()
1030!!$append(tmp,myfn(1))
1031!!$CALL packarray(tmp)
1032!!$print *,tmp%array
1033
1034integer :: i,j,k,iin,iout
1035logical :: allfoundout, foundout, somefoundin, foundin
1036integer,save :: order,num
1037character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
1038
1039
1040! delete only on the main call
1041if (.not. optio_log(recurse)) then
1042 CALL l4f_log(l4f_debug, "oracle: delete and register")
1046 call fnregister(maybefn)
1047 call fnregister(usefullfn)
1048 call fnregister(myvfn)
1049 order=0
1050end if
1051
1052CALL l4f_log(l4f_debug, "oracle: order "//t2c(order))
1053newbin=cmiss
1054newbin(:size(mybin))=mybin
1055newbout=cmiss
1056newbout(:size(mybin))=mybin
1057
1058! order is level to put functions
1059order=order+1
1060somefoundin = .false.
1061num=count(c_e(maybefn%fnds))
1062tmpbin=cmiss
1063
1064!search for functions starting from input
1066 foundin = .true.
1068 if (.not. any(vfn%fnds(i)%bin(j) == newbin)) foundin = .false.
1069!!$ print *,"compare: ",vfn(i)%bin(j)
1070!!$ print *,"with: ",mybin
1071 end do
1072 if (foundin) then
1073 CALL l4f_log(l4f_debug, "oracle: register "//trim(vfn%fnds(i)%name))
1074 call fnregister(maybefn,vfn%fnds(i),order)
1075 do k=1,size(vfn%fnds(i)%bout)
1076 tmpbin(firsttrue(.not. c_e(tmpbin)))=vfn%fnds(i)%bout(k)
1077 newbout(firsttrue(.not. c_e(newbout)))=vfn%fnds(i)%bout(k)
1078 end do
1079 somefoundin = .true.
1080 end if
1081end do
1082
1084 newbin(firsttrue(.not. c_e(newbin)))=tmpbin(i)
1085end do
1086
1087! here bin and bout are bigger (newbin, newbout)
1088! by the output of applicable functions
1089
1090
1091!check if we can work anymore
1092stat = .false.
1093if (.not. somefoundin) return
1095
1096!check if we have finish
1097allfoundout = .true.
1099 foundout = .false.
1101 if (newbout(j) == mybout(i)) foundout = .true.
1102 end do
1103 if (.not. foundout) allfoundout = .false.
1104end do
1105
1106
1107! ok, all is done
1108if (allfoundout) then
1109
1110!!$ print *, "intermediate"
1111!!$ do i =1,size(maybefn)
1112!!$ if (c_e(maybefn(i))) print *,maybefn(i)
1113!!$ end do
1114
1115 ! remove dry branch
1116 newbout=cmiss
1117 newbout(:size(mybout))=mybout
1118 tmpbin=cmiss
1119
1121 if (maybefn%fnds(i)%order /= order) then
1122 CALL l4f_log(l4f_debug, "oracle: change order "//t2c(maybefn%fnds(i)%order))
1123 order=maybefn%fnds(i)%order
1124 iin=count(c_e(tmpbin))
1125 iout=count(c_e(newbout))
1126 newbout(iout+1:iout+iin)=tmpbin(:iin)
1127 tmpbin=cmiss
1128 end if
1129
1130 !print *,"search:",newbout(:firsttrue(.not. c_e(newbout)))
1131
1132 foundout = .false.
1134 if (any(maybefn%fnds(i)%bout(:) == newbout(j))) foundout = .true.
1135 end do
1136 if (foundout) then
1137 CALL l4f_log(l4f_debug, "oracle: other register "// trim(maybefn%fnds(i)%name))
1138 call fnregister(myvfn,maybefn%fnds(i),order)
1140 tmpbin(firsttrue(.not. c_e(tmpbin)))=maybefn%fnds(i)%bin(k)
1141 end do
1142 end if
1143 end do
1144
1145 stat = .true.
1146
1147else
1148
1149 stat=oracle(newbin,mybout,vfn,myvfn,.true.)
1150
1151end if
1152
1153! delete on exit only on the main call
1154if (.not. optio_log(recurse)) then
1157 order=0
1158end if
1159
1160end function oracle
1161
1162
1163!> This function try to suggest you some road to obtain the variable you want.
1164!! Starting from desciption of output and a vector of available functions
1165!! provide to you some possible starting points.
1166recursive logical function shoppinglist(mybout,vfn,myvfn, copy, recurse) result(stat)
1167type(fndsv),intent(in) :: vfn !< vector function object available
1168character(len=*),intent(in) :: mybout(:) !< standard table B description of output
1169type(fndsv),intent(inout) :: myvfn !< vector function object that solve the problem
1170logical,intent(in),optional :: copy !< if .true. the copy functions are localy added to vfn (you can have input variable copyed to output)
1171logical,intent(in),optional :: recurse !< set to .true. when called in recurse
1172
1173type(fndsv) :: vfntmp
1174integer :: i,j,k
1175logical :: somefoundout
1176integer,save :: order
1177character(len=10) :: newbout(nmaxb)
1178
1179stat=.true.
1180newbout=cmiss
1181vfntmp=vfn
1182
1183! delete only on the main call
1184if (.not. optio_log(recurse)) then
1185 CALL l4f_log(l4f_debug, "shoppinglist: main call (delete and register)")
1186
1188 call fnregister(myvfn)
1189 order=0
1190 newbout(:size(mybout))=mybout
1191
1192 if (optio_log(copy)) call register_copy(vfntmp,mybout)
1193
1194else
1195
1196 CALL l4f_log(l4f_debug, "shoppinglist: sub call; order:"//t2c(order))
1197
1198 !print*,pack(newbout,c_e(newbout))
1199
1201 !print*,"order:",myvfn%fnds(i)%order, order
1202 if (myvfn%fnds(i)%order == order) then
1203 do k=1,size(myvfn%fnds(i)%bin(:))
1204 newbout(firsttrue(.not. c_e(newbout)))=myvfn%fnds(i)%bin(k)
1205 end do
1206 end if
1207 end do
1208
1209end if
1210
1211!print*,pack(newbout,c_e(newbout))
1212
1213! order is level to put functions
1214order=order+1
1215somefoundout = .false.
1216
1217CALL l4f_log(l4f_debug, "shoppinglist: order "//t2c(order))
1218
1219!search for functions outputing my output
1221 !call display(vfntmp%fnds(i))
1223 if (any(vfntmp%fnds(i)%bout(j) == newbout)) then
1224 CALL l4f_log(l4f_debug, "shoppinglist: register "//trim(vfntmp%fnds(i)%name))
1225 call fnregister(myvfn,vfntmp%fnds(i),order)
1226 somefoundout = .true.
1227 end if
1228 end do
1229end do
1230
1231!check if we can work anymore
1232if (.not. somefoundout) return
1233
1234stat=shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy), recurse=.true.)
1235
1236! delete on exit only on the main call
1237if (.not. optio_log(recurse)) then
1239 order=0
1240end if
1241
1242end function shoppinglist
1243
1244
1245!> Execute the function to obtain what you have requested to oracle.
1246!! This is a sample only routine for the cousine test case.
1247subroutine makev(mayvfn,mybin,mybout,myin,myout)
1248type(fndsv),intent(inout) :: mayvfn !< vector function object that solve the problem
1249character(len=*),intent(in) :: mybin(:) !< standard table B description of input
1250character(len=*),intent(in) :: mybout(:) !< standard table B description of output
1251real,intent(in) :: myin(:,:) !< data input (ndata,nparameters)
1252real,intent(out) :: myout(:,:)!< data output (ndata,nparameters)
1253integer :: i,j
1254character(len=10) :: newbout(mayvfn%nout)
1255
1256
1257newbout=cmiss
1258do i=1, size(mayvfn%fnds)
1260 do j=1, size(mayvfn%fnds(i)%bout)
1262 if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0) then
1263 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
1264 end if
1265 end if
1266 end do
1267 end if
1268end do
1269
1270do i=size(mayvfn%fnds),1,-1
1272 print *,"name:",mayvfn%fnds(i)%name,"order:",mayvfn%fnds(i)%order
1273
1274 call mayvfn%fnds(i)%fn(mybin,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
1275 !print *,"make",i,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout
1276 end if
1277end do
1278
1279!!$#include "arrayof_post.F90"
1280
1281end subroutine makev
1282
1283
1284
1285
1286!> Produce a vector of list of variables usefull for produce your request.
1287function compile_sl(myvfn)
1288
1289type(shoplists) :: compile_sl
1290type(fndsv),intent(in) :: myvfn !< vector function object that solve the problem
1291
1292integer :: i,j,k,nshoplist,nvar,nfunc,indfunc,indvar
1293CHARACTER(len=10),allocatable :: bvartmp(:)
1294
1295indfunc=0
1296nshoplist=(maxval(myvfn%fnds(:)%order))
1297nshoplist=max(0,nshoplist)
1298allocate (compile_sl%shoplist(nshoplist))
1299
1300nvar=1
1301
1302do i=1,nshoplist
1303 nfunc=count(myvfn%fnds(:)%order==i)
1304 allocate(compile_sl%shoplist(i)%bvar(nvar-1))
1305 if (i > 1) then
1306 compile_sl%shoplist(i)%bvar = compile_sl%shoplist(i-1)%bvar
1307 do j = indfunc+1, indfunc+nfunc
1308 do k = 1, size(myvfn%fnds(j)%bout)
1309 indvar=index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bout(k))
1310 if (indvar > 0) compile_sl%shoplist(i)%bvar(indvar)=cmiss
1311 end do
1312 end do
1313 end if
1314 do j = indfunc+1, indfunc+nfunc
1315 do k = 1, size(myvfn%fnds(j)%bin)
1316 if (index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bin(k)) > 0 ) cycle
1317 allocate(bvartmp(nvar))
1318 bvartmp(:nvar-1)=compile_sl%shoplist(i)%bvar
1319 call move_alloc(from=bvartmp ,to=compile_sl%shoplist(i)%bvar)
1320 compile_sl%shoplist(i)%bvar(nvar)=myvfn%fnds(j)%bin(k)
1321 nvar=nvar+1
1322 end do
1323 end do
1324 indfunc=indfunc+nfunc
1325end do
1326
1327do i=1,nshoplist
1328 compile_sl%shoplist(i)%bvar=pack(compile_sl%shoplist(i)%bvar,c_e(compile_sl%shoplist(i)%bvar))
1329end do
1330
1331end function compile_sl
1332
1334
1335!>\example example_alchimia.f03
1336!!\brief Sample program to demostrate the alchimia module.
1337!!
1338!! This module use cuisine problems to demostrate the capacity of the module.
1339
1340!>\example example_alchimiavg6d.f03
1341!!\brief Sample program to demostrate the alchimia module with volgrid6d.
1342
1343!>\example example_alchimiav7d.f03
1344!! \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 |