libsim Versione 7.2.1

◆ 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 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
784module alchimia
785
789USE log4fortran
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
818type fndsv
819 integer :: nin = imiss
820 integer :: nout = imiss
821 type(fnds),allocatable :: fnds(:)
822end type fndsv
823
825type shoplist
826 CHARACTER(len=10),allocatable :: bvar(:)
827end type shoplist
828
830type shoplists
831 type(shoplist),allocatable :: shoplist(:)
832end type shoplists
833
835interface c_e
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
848interface display
849 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
850end interface
851
853interface delete
854 module procedure fnv_delete
855end interface
856
858interface make
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
871public fnds,fndsv,make,init,c_e,display,delete,fnregister,oracle,register_copy
872public shoppinglist, shoplists, compile_sl
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
1031if (c_e(fn%order) .and. c_e(fn%priority)) then
1032 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
1033else if (c_e(fn%order)) then
1034 print *,"function : ",fn%name," order :",fn%order
1035else if (c_e(fn%priority)) then
1036 print *,"function : ",fn%name," priority :",fn%priority
1037else
1038 print *,"function : ",fn%name
1039end if
1040print *,"input : ",fn%bin (:count(c_e(fn%bin)))
1041print *,"output : ",fn%bout(:count(c_e(fn%bout)))
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:"
1055do i = count(c_e(fnv%fnds)),1,-1
1056 call display(fnv%fnds(i))
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
1072do i = count(c_e(fnv%fnds)),1,-1
1073 if (fnv%fnds(i)%order == order ) then
1074 call display(fnv%fnds(i))
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
1090 call display(vfnv(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")
1124 call delete(maybefn)
1125 call delete(usefullfn)
1126 call delete(myvfn)
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
1146do i =1, count(c_e(vfn%fnds))
1147 foundin = .true.
1148 do j = 1, count(c_e(vfn%fnds(i)%bin(:)))
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
1164do i = 1, count(c_e(tmpbin))
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
1175if (num == count(c_e(maybefn%fnds))) return
1176
1177!check if we have finish
1178allfoundout = .true.
1179do i=1, count(c_e(mybout))
1180 foundout = .false.
1181 do j =1, count(c_e(newbout))
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
1201 do i = count(c_e(maybefn%fnds)),1,-1
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.
1214 do j=1, count(c_e(newbout))
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)
1220 do k=1,count(c_e(maybefn%fnds(i)%bin))
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
1236 call delete(maybefn)
1237 call delete(usefullfn)
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
1268 call delete(myvfn)
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
1281 do i=1, count(c_e(myvfn%fnds(:)))
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
1301do i =1, count(c_e(vfntmp%fnds))
1302 !call display(vfntmp%fnds(i))
1303 do j = 1, count(c_e(vfntmp%fnds(i)%bout(:)))
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
1319 call delete(vfntmp)
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)
1340 if (c_e(mayvfn%fnds(i))) then
1341 do j=1, size(mayvfn%fnds(i)%bout)
1342 if (c_e(mayvfn%fnds(i)%bout(j))) then
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
1352 if (c_e(mayvfn%fnds(i))) then
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
1414end module alchimia
1415
1420
1423
Check missing values for fnds.
Definition: alchimia.F03:265
Delete fndsv.
Definition: alchimia.F03:283
show on the screen the fnds and fndsv structure
Definition: alchimia.F03:278
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.
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:248
shoplist are list of variables
Definition: alchimia.F03:255
Vector of shoplists that are list of variables.
Definition: alchimia.F03:260

Generated with Doxygen.