libsim Versione 7.1.11

◆ 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 683 del file alchimia.F03.

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

Generated with Doxygen.