libsim Versione 7.1.11
|
◆ 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 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
710
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
744 integer :: nin = imiss
745 integer :: nout = imiss
746 type(fnds),allocatable :: fnds(:)
748
751 CHARACTER(len=10),allocatable :: bvar(:)
753
756 type(shoplist),allocatable :: shoplist(:)
758
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
774 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
775end interface
776
779 module procedure fnv_delete
780end interface
781
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
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
957 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
959 print *,"function : ",fn%name," order :",fn%order
961 print *,"function : ",fn%name," priority :",fn%priority
962else
963 print *,"function : ",fn%name
964end if
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:"
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
998 if (fnv%fnds(i)%order == order ) then
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
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")
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
1072 foundin = .true.
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
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
1101
1102!check if we have finish
1103allfoundout = .true.
1105 foundout = .false.
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
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.
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)
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
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
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
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
1227 !call display(vfntmp%fnds(i))
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
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)
1266 do j=1, size(mayvfn%fnds(i)%bout)
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
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
1340
1345
1348
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. Definition: array_utilities.F90:218 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:254 |