libsim Versione 7.2.1
|
◆ 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
699
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(:)
719 CHARACTER(len=10),intent(in) :: mybout(:)
720 CHARACTER(len=10),intent(in) :: bin(:)
721 CHARACTER(len=10),intent(in) :: bout(:)
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(:)
730 CHARACTER(len=10),allocatable :: bout(:)
731 integer :: priority
732 integer :: order
733 procedure(elabora) ,nopass, pointer :: fn
734end type fnds
735
738 integer :: nin = imiss
739 integer :: nout = imiss
740 type(fnds),allocatable :: fnds(:)
742
745 CHARACTER(len=10),allocatable :: bvar(:)
747
750 type(shoplist),allocatable :: shoplist(:)
752
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
768 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
769end interface
770
773 module procedure fnv_delete
774end interface
775
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
796subroutine register_copy(vfn,bin)
797
798 type(fndsv),intent(inout) :: vfn
799 CHARACTER(len=10),intent(in) :: bin(:)
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(:)
810 CHARACTER(len=10),intent(in) :: mybout(:)
811 CHARACTER(len=10),intent(in) :: bin(:)
812 CHARACTER(len=10),intent(in) :: bout(:)
813 real, intent(in) :: in(:,:)
814 real, intent(out) :: out(:,:)
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
829subroutine fn_init(fn,name,bin,bout,priority,order,func)
830type(fnds),intent(inout) :: fn
831CHARACTER(len=*),optional :: name
832CHARACTER(len=*),optional :: bin(:)
833CHARACTER(len=*),optional :: bout(:)
834integer,optional :: priority
835integer,optional :: order
836procedure(elabora),optional :: func
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
867elemental subroutine fnv_delete(fnv)
868type(fndsv),intent(inout) :: fnv
869type(fndsv) :: fn
870
871fnv=fn
872
873end subroutine fnv_delete
874
878subroutine fnregister(vfn,fn,order)
879
880type(fndsv),intent(inout) :: vfn
881type(fnds),intent(in),optional :: fn
882integer,optional :: order
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
917elemental logical function c_e_fn(fn)
918type(fnds),intent(in) :: fn
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
933subroutine sl_display(sl)
934type(shoplists),intent(in) :: sl
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
948subroutine fn_display(fn)
949type(fnds),intent(in) :: fn
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
966subroutine fnv_display(fnv)
967type(fndsv),intent(in) :: fnv
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
983subroutine fnv_display_byorder(fnv,order)
984type(fndsv),intent(in) :: fnv
985integer,intent(in) :: order
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
1002subroutine vfnv_display(vfnv)
1003type(fndsv),intent(in) :: vfnv(:)
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
1019recursive logical function oracle(mybin,mybout,vfn,myvfn,recurse) result(stat)
1020type(fndsv),intent(in) :: vfn
1021character(len=*),intent(in) :: mybin(:)
1022character(len=*),intent(in) :: mybout(:)
1023type(fndsv),intent(out) :: myvfn
1024logical,optional :: 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
1166recursive logical function shoppinglist(mybout,vfn,myvfn, copy, recurse) result(stat)
1167type(fndsv),intent(in) :: vfn
1168character(len=*),intent(in) :: mybout(:)
1169type(fndsv),intent(inout) :: myvfn
1170logical,intent(in),optional :: copy
1171logical,intent(in),optional :: 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
1247subroutine makev(mayvfn,mybin,mybout,myin,myout)
1248type(fndsv),intent(inout) :: mayvfn
1249character(len=*),intent(in) :: mybin(:)
1250character(len=*),intent(in) :: mybout(:)
1251real,intent(in) :: myin(:,:)
1252real,intent(out) :: myout(:,:)
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
1287function compile_sl(myvfn)
1288
1289type(shoplists) :: compile_sl
1290type(fndsv),intent(in) :: myvfn
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
1339
1342
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 |