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