libsim Versione 7.2.0

◆ shoppinglist()

recursive logical function, public shoppinglist ( character(len=*), dimension(:), intent(in)  mybout,
type(fndsv), intent(in)  vfn,
type(fndsv), intent(inout)  myvfn,
logical, intent(in), optional  copy,
logical, intent(in), optional  recurse 
)

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.

Parametri
[in]vfnvector function object available
[in]myboutstandard table B description of output
[in,out]myvfnvector function object that solve the problem
[in]copyif .true. the copy functions are localy added to vfn (you can have input variable copyed to output)
[in]recurseset to .true. when called in recurse

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
703module alchimia
704
708USE log4fortran
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
737type fndsv
738 integer :: nin = imiss
739 integer :: nout = imiss
740 type(fnds),allocatable :: fnds(:)
741end type fndsv
742
744type shoplist
745 CHARACTER(len=10),allocatable :: bvar(:)
746end type shoplist
747
749type shoplists
750 type(shoplist),allocatable :: shoplist(:)
751end type shoplists
752
754interface c_e
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
767interface display
768 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
769end interface
770
772interface delete
773 module procedure fnv_delete
774end interface
775
777interface make
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
790public fnds,fndsv,make,init,c_e,display,delete,fnregister,oracle,register_copy
791public shoppinglist, shoplists, compile_sl
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
950if (c_e(fn%order) .and. c_e(fn%priority)) then
951 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
952else if (c_e(fn%order)) then
953 print *,"function : ",fn%name," order :",fn%order
954else if (c_e(fn%priority)) then
955 print *,"function : ",fn%name," priority :",fn%priority
956else
957 print *,"function : ",fn%name
958end if
959print *,"input : ",fn%bin (:count(c_e(fn%bin)))
960print *,"output : ",fn%bout(:count(c_e(fn%bout)))
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:"
974do i = count(c_e(fnv%fnds)),1,-1
975 call display(fnv%fnds(i))
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
991do i = count(c_e(fnv%fnds)),1,-1
992 if (fnv%fnds(i)%order == order ) then
993 call display(fnv%fnds(i))
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
1009 call display(vfnv(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")
1043 call delete(maybefn)
1044 call delete(usefullfn)
1045 call delete(myvfn)
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
1065do i =1, count(c_e(vfn%fnds))
1066 foundin = .true.
1067 do j = 1, count(c_e(vfn%fnds(i)%bin(:)))
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
1083do i = 1, count(c_e(tmpbin))
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
1094if (num == count(c_e(maybefn%fnds))) return
1095
1096!check if we have finish
1097allfoundout = .true.
1098do i=1, count(c_e(mybout))
1099 foundout = .false.
1100 do j =1, count(c_e(newbout))
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
1120 do i = count(c_e(maybefn%fnds)),1,-1
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.
1133 do j=1, count(c_e(newbout))
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)
1139 do k=1,count(c_e(maybefn%fnds(i)%bin))
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
1155 call delete(maybefn)
1156 call delete(usefullfn)
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
1187 call delete(myvfn)
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
1200 do i=1, count(c_e(myvfn%fnds(:)))
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
1220do i =1, count(c_e(vfntmp%fnds))
1221 !call display(vfntmp%fnds(i))
1222 do j = 1, count(c_e(vfntmp%fnds(i)%bout(:)))
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
1238 call delete(vfntmp)
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)
1259 if (c_e(mayvfn%fnds(i))) then
1260 do j=1, size(mayvfn%fnds(i)%bout)
1261 if (c_e(mayvfn%fnds(i)%bout(j))) then
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
1271 if (c_e(mayvfn%fnds(i))) then
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
1333end module alchimia
1334
1339
1342
Check missing values for fnds.
Definition: alchimia.F03:265
Delete fndsv.
Definition: alchimia.F03:283
show on the screen the fnds and fndsv structure
Definition: alchimia.F03:278
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.
Utilities for CHARACTER variables.
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Vector of function to transform the input to alchimia module.
Definition: alchimia.F03:248
shoplist are list of variables
Definition: alchimia.F03:255
Vector of shoplists that are list of variables.
Definition: alchimia.F03:260

Generated with Doxygen.