libsim Versione 7.1.11
|
◆ makev()
Execute the function to obtain what you have requested to oracle. This is a sample only routine for the cousine test case.
Definizione alla linea 764 del file alchimia.F03. 765! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
766! authors:
767! Davide Cesari <dcesari@arpa.emr.it>
768! Paolo Patruno <ppatruno@arpa.emr.it>
769
770! This program is free software; you can redistribute it and/or
771! modify it under the terms of the GNU General Public License as
772! published by the Free Software Foundation; either version 2 of
773! the License, or (at your option) any later version.
774
775! This program is distributed in the hope that it will be useful,
776! but WITHOUT ANY WARRANTY; without even the implied warranty of
777! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
778! GNU General Public License for more details.
779
780! You should have received a copy of the GNU General Public License
781! along with this program. If not, see <http://www.gnu.org/licenses/>.
782#include "config.h"
783
786
791
797
798IMPLICIT NONE
799
800integer, parameter :: nmaxb=100
801
802abstract interface
803 subroutine elabora(mybin,mybout,bin,bout,in,out)
804 import
805 CHARACTER(len=10),intent(in) :: mybin(:)
806 CHARACTER(len=10),intent(in) :: mybout(:)
807 CHARACTER(len=10),intent(in) :: bin(:)
808 CHARACTER(len=10),intent(in) :: bout(:)
809 real, intent(in) :: in(:,:)
810 real, intent(out) :: out(:,:)
811 end subroutine elabora
812end interface
813
814type fnds
815 CHARACTER(len=50) :: name=cmiss
816 CHARACTER(len=10),allocatable :: bin(:)
817 CHARACTER(len=10),allocatable :: bout(:)
818 integer :: priority
819 integer :: order
820 procedure(elabora) ,nopass, pointer :: fn
821end type fnds
822
825 integer :: nin = imiss
826 integer :: nout = imiss
827 type(fnds),allocatable :: fnds(:)
829
832 CHARACTER(len=10),allocatable :: bvar(:)
834
837 type(shoplist),allocatable :: shoplist(:)
839
842 module procedure c_e_fn
843end interface
844
845interface OPERATOR (==)
846 module procedure equal_fn
847end interface
848
849interface init
850 module procedure fn_init
851end interface
852
855 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
856end interface
857
860 module procedure fnv_delete
861end interface
862
865 module procedure makev
866end interface
867
868
869!!$#define ARRAYOF_ORIGTYPE TYPE(fnds)
870!!$#define ARRAYOF_TYPE arrayof_fnds
871!!$#define ARRAYOF_ORIGEQ 0
872!!$#include "arrayof_pre.F90"
873!!$! from arrayof
874!!$PUBLIC insert, append, remove, packarray
875!!$PUBLIC insert_unique, append_unique
876private
879
880contains
881
883subroutine register_copy(vfn,bin)
884
885 type(fndsv),intent(inout) :: vfn
886 CHARACTER(len=10),intent(in) :: bin(:)
887 integer :: i
888
889 do i=1, size(bin)
890 call fnregister(vfn,alchimia_copy_def(bin(i)))
891 end do
892
893end subroutine register_copy
894
895subroutine alchimia_copy(mybin,mybout,bin,bout,in,out)
896 CHARACTER(len=10),intent(in) :: mybin(:)
897 CHARACTER(len=10),intent(in) :: mybout(:)
898 CHARACTER(len=10),intent(in) :: bin(:)
899 CHARACTER(len=10),intent(in) :: bout(:)
900 real, intent(in) :: in(:,:)
901 real, intent(out) :: out(:,:)
902
903 out(:,index_c(mybout,bout(1)))=in(:,index_c(mybin,bin(1)))
904
905end subroutine alchimia_copy
906
907type(fnds) function alchimia_copy_def(bvar)
908 CHARACTER(len=10),intent(in) :: bvar
909
910 call init(alchimia_copy_def,"copy"//bvar,&
911 [character(len=10) :: bvar],&
912 [character(len=10) :: bvar],0,func=alchimia_copy)
913end function alchimia_copy_def
914
916subroutine fn_init(fn,name,bin,bout,priority,order,func)
917type(fnds),intent(inout) :: fn
918CHARACTER(len=*),optional :: name
919CHARACTER(len=*),optional :: bin(:)
920CHARACTER(len=*),optional :: bout(:)
921integer,optional :: priority
922integer,optional :: order
923procedure(elabora),optional :: func
924
925call optio(name,fn%name)
926
927if (present(bin)) then
928 fn%bin=bin
929else
930 allocate(fn%bin(1))
931 fn%bin=cmiss
932end if
933
934if (present(bout)) then
935 fn%bout=bout
936else
937 allocate(fn%bout(1))
938 fn%bout=cmiss
939end if
940
941call optio(priority,fn%priority)
942call optio(order,fn%order)
943
944if (present(func)) then
945 fn%fn => func
946else
947 fn%fn => null()
948end if
949
950end subroutine fn_init
951
952
954elemental subroutine fnv_delete(fnv)
955type(fndsv),intent(inout) :: fnv
956type(fndsv) :: fn
957
958fnv=fn
959
960end subroutine fnv_delete
961
965subroutine fnregister(vfn,fn,order)
966
967type(fndsv),intent(inout) :: vfn
968type(fnds),intent(in),optional :: fn
969integer,optional :: order
970
971integer :: nfn
972type(fndsv) :: vfntmp
973
974if (.not. allocated(vfn%fnds))then
975 allocate(vfn%fnds(0))
976 vfn%nin=0
977 vfn%nout=0
978end if
979
980if (present(fn))then
981
982 if (firsttrue(vfn%fnds == fn) /= 0) return
983 nfn=size(vfn%fnds)
984
985 allocate(vfntmp%fnds(nfn+1))
986
987 vfntmp%fnds(:nfn)=vfn%fnds
988
989 call move_alloc(from=vfntmp%fnds ,to=vfn%fnds)
990
991 vfn%fnds(nfn+1)=fn
992 if (present(order)) vfn%fnds(nfn+1)%order = order
993
994 vfn%nin=vfn%nin+size(fn%bin)
995 vfn%nout=vfn%nout+size(fn%bout)
996
997 CALL l4f_log(l4f_debug, 'fnregister: adding function object '//trim(fn%name)//' ; nout '//t2c(vfn%nout))
998
999end if
1000
1001end subroutine fnregister
1002
1004elemental logical function c_e_fn(fn)
1005type(fnds),intent(in) :: fn
1006
1007c_e_fn= c_e(fn%name)
1008
1009end function c_e_fn
1010
1011elemental logical function equal_fn(this,that)
1012type(fnds),intent(in) :: this,that
1013
1014equal_fn= this%name == that%name
1015
1016end function equal_fn
1017
1018
1020subroutine sl_display(sl)
1021type(shoplists),intent(in) :: sl
1022
1023integer :: i
1024
1025do i = 1, size(sl%shoplist)
1026 print *,"shopping list : ",i
1027 print *,"varlist : ",sl%shoplist(i)%bvar
1028 print *,""
1029end do
1030
1031end subroutine sl_display
1032
1033
1035subroutine fn_display(fn)
1036type(fnds),intent(in) :: fn
1038 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
1040 print *,"function : ",fn%name," order :",fn%order
1042 print *,"function : ",fn%name," priority :",fn%priority
1043else
1044 print *,"function : ",fn%name
1045end if
1048print *,""
1049
1050end subroutine fn_display
1051
1053subroutine fnv_display(fnv)
1054type(fndsv),intent(in) :: fnv
1055integer :: i
1056
1057if (.not. allocated(fnv%fnds))return
1058
1059print *,"-------------------------------------------------"
1060print *, "Here the function tree:"
1063end do
1064print *,"-------------------------------------------------"
1065end subroutine fnv_display
1066
1067
1068
1070subroutine fnv_display_byorder(fnv,order)
1071type(fndsv),intent(in) :: fnv
1072integer,intent(in) :: order
1073
1074integer :: i
1075
1076print *,"-------------------------------------------------"
1077print *, "Here the function tree for order: ",order
1079 if (fnv%fnds(i)%order == order ) then
1081 end if
1082end do
1083print *,"-------------------------------------------------"
1084end subroutine fnv_display_byorder
1085
1086
1087
1089subroutine vfnv_display(vfnv)
1090type(fndsv),intent(in) :: vfnv(:)
1091integer :: i
1092
1093print *,">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
1094do i = 1, size(vfnv)
1095 print*,">> Function tree number:",i
1097end do
1098print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
1099end subroutine vfnv_display
1100
1101
1102
1106recursive logical function oracle(mybin,mybout,vfn,myvfn,recurse) result(stat)
1107type(fndsv),intent(in) :: vfn
1108character(len=*),intent(in) :: mybin(:)
1109character(len=*),intent(in) :: mybout(:)
1110type(fndsv),intent(out) :: myvfn
1111logical,optional :: recurse
1112
1113type(fndsv),save :: usefullfn,maybefn
1114
1115!!$type(arrayof_fnds) :: tmp
1116!!$tmp = arrayof_fnds_new()
1117!!$append(tmp,myfn(1))
1118!!$CALL packarray(tmp)
1119!!$print *,tmp%array
1120
1121integer :: i,j,k,iin,iout
1122logical :: allfoundout, foundout, somefoundin, foundin
1123integer,save :: order,num
1124character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
1125
1126
1127! delete only on the main call
1128if (.not. optio_log(recurse)) then
1129 CALL l4f_log(l4f_debug, "oracle: delete and register")
1133 call fnregister(maybefn)
1134 call fnregister(usefullfn)
1135 call fnregister(myvfn)
1136 order=0
1137end if
1138
1139CALL l4f_log(l4f_debug, "oracle: order "//t2c(order))
1140newbin=cmiss
1141newbin(:size(mybin))=mybin
1142newbout=cmiss
1143newbout(:size(mybin))=mybin
1144
1145! order is level to put functions
1146order=order+1
1147somefoundin = .false.
1148num=count(c_e(maybefn%fnds))
1149tmpbin=cmiss
1150
1151!search for functions starting from input
1153 foundin = .true.
1155 if (.not. any(vfn%fnds(i)%bin(j) == newbin)) foundin = .false.
1156!!$ print *,"compare: ",vfn(i)%bin(j)
1157!!$ print *,"with: ",mybin
1158 end do
1159 if (foundin) then
1160 CALL l4f_log(l4f_debug, "oracle: register "//trim(vfn%fnds(i)%name))
1161 call fnregister(maybefn,vfn%fnds(i),order)
1162 do k=1,size(vfn%fnds(i)%bout)
1163 tmpbin(firsttrue(.not. c_e(tmpbin)))=vfn%fnds(i)%bout(k)
1164 newbout(firsttrue(.not. c_e(newbout)))=vfn%fnds(i)%bout(k)
1165 end do
1166 somefoundin = .true.
1167 end if
1168end do
1169
1171 newbin(firsttrue(.not. c_e(newbin)))=tmpbin(i)
1172end do
1173
1174! here bin and bout are bigger (newbin, newbout)
1175! by the output of applicable functions
1176
1177
1178!check if we can work anymore
1179stat = .false.
1180if (.not. somefoundin) return
1182
1183!check if we have finish
1184allfoundout = .true.
1186 foundout = .false.
1188 if (newbout(j) == mybout(i)) foundout = .true.
1189 end do
1190 if (.not. foundout) allfoundout = .false.
1191end do
1192
1193
1194! ok, all is done
1195if (allfoundout) then
1196
1197!!$ print *, "intermediate"
1198!!$ do i =1,size(maybefn)
1199!!$ if (c_e(maybefn(i))) print *,maybefn(i)
1200!!$ end do
1201
1202 ! remove dry branch
1203 newbout=cmiss
1204 newbout(:size(mybout))=mybout
1205 tmpbin=cmiss
1206
1208 if (maybefn%fnds(i)%order /= order) then
1209 CALL l4f_log(l4f_debug, "oracle: change order "//t2c(maybefn%fnds(i)%order))
1210 order=maybefn%fnds(i)%order
1211 iin=count(c_e(tmpbin))
1212 iout=count(c_e(newbout))
1213 newbout(iout+1:iout+iin)=tmpbin(:iin)
1214 tmpbin=cmiss
1215 end if
1216
1217 !print *,"search:",newbout(:firsttrue(.not. c_e(newbout)))
1218
1219 foundout = .false.
1221 if (any(maybefn%fnds(i)%bout(:) == newbout(j))) foundout = .true.
1222 end do
1223 if (foundout) then
1224 CALL l4f_log(l4f_debug, "oracle: other register "// trim(maybefn%fnds(i)%name))
1225 call fnregister(myvfn,maybefn%fnds(i),order)
1227 tmpbin(firsttrue(.not. c_e(tmpbin)))=maybefn%fnds(i)%bin(k)
1228 end do
1229 end if
1230 end do
1231
1232 stat = .true.
1233
1234else
1235
1236 stat=oracle(newbin,mybout,vfn,myvfn,.true.)
1237
1238end if
1239
1240! delete on exit only on the main call
1241if (.not. optio_log(recurse)) then
1244 order=0
1245end if
1246
1247end function oracle
1248
1249
1253recursive logical function shoppinglist(mybout,vfn,myvfn, copy, recurse) result(stat)
1254type(fndsv),intent(in) :: vfn
1255character(len=*),intent(in) :: mybout(:)
1256type(fndsv),intent(inout) :: myvfn
1257logical,intent(in),optional :: copy
1258logical,intent(in),optional :: recurse
1259
1260type(fndsv) :: vfntmp
1261integer :: i,j,k
1262logical :: somefoundout
1263integer,save :: order
1264character(len=10) :: newbout(nmaxb)
1265
1266stat=.true.
1267newbout=cmiss
1268vfntmp=vfn
1269
1270! delete only on the main call
1271if (.not. optio_log(recurse)) then
1272 CALL l4f_log(l4f_debug, "shoppinglist: main call (delete and register)")
1273
1275 call fnregister(myvfn)
1276 order=0
1277 newbout(:size(mybout))=mybout
1278
1279 if (optio_log(copy)) call register_copy(vfntmp,mybout)
1280
1281else
1282
1283 CALL l4f_log(l4f_debug, "shoppinglist: sub call; order:"//t2c(order))
1284
1285 !print*,pack(newbout,c_e(newbout))
1286
1288 !print*,"order:",myvfn%fnds(i)%order, order
1289 if (myvfn%fnds(i)%order == order) then
1290 do k=1,size(myvfn%fnds(i)%bin(:))
1291 newbout(firsttrue(.not. c_e(newbout)))=myvfn%fnds(i)%bin(k)
1292 end do
1293 end if
1294 end do
1295
1296end if
1297
1298!print*,pack(newbout,c_e(newbout))
1299
1300! order is level to put functions
1301order=order+1
1302somefoundout = .false.
1303
1304CALL l4f_log(l4f_debug, "shoppinglist: order "//t2c(order))
1305
1306!search for functions outputing my output
1308 !call display(vfntmp%fnds(i))
1310 if (any(vfntmp%fnds(i)%bout(j) == newbout)) then
1311 CALL l4f_log(l4f_debug, "shoppinglist: register "//trim(vfntmp%fnds(i)%name))
1312 call fnregister(myvfn,vfntmp%fnds(i),order)
1313 somefoundout = .true.
1314 end if
1315 end do
1316end do
1317
1318!check if we can work anymore
1319if (.not. somefoundout) return
1320
1321stat=shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy), recurse=.true.)
1322
1323! delete on exit only on the main call
1324if (.not. optio_log(recurse)) then
1326 order=0
1327end if
1328
1329end function shoppinglist
1330
1331
1334subroutine makev(mayvfn,mybin,mybout,myin,myout)
1335type(fndsv),intent(inout) :: mayvfn
1336character(len=*),intent(in) :: mybin(:)
1337character(len=*),intent(in) :: mybout(:)
1338real,intent(in) :: myin(:,:)
1339real,intent(out) :: myout(:,:)
1340integer :: i,j
1341character(len=10) :: newbout(mayvfn%nout)
1342
1343
1344newbout=cmiss
1345do i=1, size(mayvfn%fnds)
1347 do j=1, size(mayvfn%fnds(i)%bout)
1349 if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0) then
1350 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
1351 end if
1352 end if
1353 end do
1354 end if
1355end do
1356
1357do i=size(mayvfn%fnds),1,-1
1359 print *,"name:",mayvfn%fnds(i)%name,"order:",mayvfn%fnds(i)%order
1360
1361 call mayvfn%fnds(i)%fn(mybin,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
1362 !print *,"make",i,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout
1363 end if
1364end do
1365
1366!!$#include "arrayof_post.F90"
1367
1368end subroutine makev
1369
1370
1371
1372
1374function compile_sl(myvfn)
1375
1376type(shoplists) :: compile_sl
1377type(fndsv),intent(in) :: myvfn
1378
1379integer :: i,j,k,nshoplist,nvar,nfunc,indfunc,indvar
1380CHARACTER(len=10),allocatable :: bvartmp(:)
1381
1382indfunc=0
1383nshoplist=(maxval(myvfn%fnds(:)%order))
1384nshoplist=max(0,nshoplist)
1385allocate (compile_sl%shoplist(nshoplist))
1386
1387nvar=1
1388
1389do i=1,nshoplist
1390 nfunc=count(myvfn%fnds(:)%order==i)
1391 allocate(compile_sl%shoplist(i)%bvar(nvar-1))
1392 if (i > 1) then
1393 compile_sl%shoplist(i)%bvar = compile_sl%shoplist(i-1)%bvar
1394 do j = indfunc+1, indfunc+nfunc
1395 do k = 1, size(myvfn%fnds(j)%bout)
1396 indvar=index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bout(k))
1397 if (indvar > 0) compile_sl%shoplist(i)%bvar(indvar)=cmiss
1398 end do
1399 end do
1400 end if
1401 do j = indfunc+1, indfunc+nfunc
1402 do k = 1, size(myvfn%fnds(j)%bin)
1403 if (index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bin(k)) > 0 ) cycle
1404 allocate(bvartmp(nvar))
1405 bvartmp(:nvar-1)=compile_sl%shoplist(i)%bvar
1406 call move_alloc(from=bvartmp ,to=compile_sl%shoplist(i)%bvar)
1407 compile_sl%shoplist(i)%bvar(nvar)=myvfn%fnds(j)%bin(k)
1408 nvar=nvar+1
1409 end do
1410 end do
1411 indfunc=indfunc+nfunc
1412end do
1413
1414do i=1,nshoplist
1415 compile_sl%shoplist(i)%bvar=pack(compile_sl%shoplist(i)%bvar,c_e(compile_sl%shoplist(i)%bvar))
1416end do
1417
1418end function compile_sl
1419
1421
1426
1429
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 |