libsim Versione 7.1.11

◆ makev()

subroutine makev ( type(fndsv), intent(inout)  mayvfn,
character(len=*), dimension(:), intent(in)  mybin,
character(len=*), dimension(:), intent(in)  mybout,
real, dimension(:,:), intent(in)  myin,
real, dimension(:,:), intent(out)  myout 
)
private

Execute the function to obtain what you have requested to oracle.

This is a sample only routine for the cousine test case.

Parametri
[in,out]mayvfnvector function object that solve the problem
[in]mybinstandard table B description of input
[in]myboutstandard table B description of output
[in]myindata input (ndata,nparameters)
[out]myoutdata output (ndata,nparameters)

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
790module alchimia
791
795USE log4fortran
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
824type fndsv
825 integer :: nin = imiss
826 integer :: nout = imiss
827 type(fnds),allocatable :: fnds(:)
828end type fndsv
829
831type shoplist
832 CHARACTER(len=10),allocatable :: bvar(:)
833end type shoplist
834
836type shoplists
837 type(shoplist),allocatable :: shoplist(:)
838end type shoplists
839
841interface c_e
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
854interface display
855 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
856end interface
857
859interface delete
860 module procedure fnv_delete
861end interface
862
864interface make
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
877public fnds,fndsv,make,init,c_e,display,delete,fnregister,oracle,register_copy
878public shoppinglist, shoplists, compile_sl
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
1037if (c_e(fn%order) .and. c_e(fn%priority)) then
1038 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
1039else if (c_e(fn%order)) then
1040 print *,"function : ",fn%name," order :",fn%order
1041else if (c_e(fn%priority)) then
1042 print *,"function : ",fn%name," priority :",fn%priority
1043else
1044 print *,"function : ",fn%name
1045end if
1046print *,"input : ",fn%bin (:count(c_e(fn%bin)))
1047print *,"output : ",fn%bout(:count(c_e(fn%bout)))
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:"
1061do i = count(c_e(fnv%fnds)),1,-1
1062 call display(fnv%fnds(i))
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
1078do i = count(c_e(fnv%fnds)),1,-1
1079 if (fnv%fnds(i)%order == order ) then
1080 call display(fnv%fnds(i))
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
1096 call display(vfnv(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")
1130 call delete(maybefn)
1131 call delete(usefullfn)
1132 call delete(myvfn)
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
1152do i =1, count(c_e(vfn%fnds))
1153 foundin = .true.
1154 do j = 1, count(c_e(vfn%fnds(i)%bin(:)))
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
1170do i = 1, count(c_e(tmpbin))
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
1181if (num == count(c_e(maybefn%fnds))) return
1182
1183!check if we have finish
1184allfoundout = .true.
1185do i=1, count(c_e(mybout))
1186 foundout = .false.
1187 do j =1, count(c_e(newbout))
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
1207 do i = count(c_e(maybefn%fnds)),1,-1
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.
1220 do j=1, count(c_e(newbout))
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)
1226 do k=1,count(c_e(maybefn%fnds(i)%bin))
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
1242 call delete(maybefn)
1243 call delete(usefullfn)
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
1274 call delete(myvfn)
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
1287 do i=1, count(c_e(myvfn%fnds(:)))
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
1307do i =1, count(c_e(vfntmp%fnds))
1308 !call display(vfntmp%fnds(i))
1309 do j = 1, count(c_e(vfntmp%fnds(i)%bout(:)))
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
1325 call delete(vfntmp)
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)
1346 if (c_e(mayvfn%fnds(i))) then
1347 do j=1, size(mayvfn%fnds(i)%bout)
1348 if (c_e(mayvfn%fnds(i)%bout(j))) then
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
1358 if (c_e(mayvfn%fnds(i))) then
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
1420end module alchimia
1421
1426
1429
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.