libsim Versione 7.1.11

◆ compile_sl()

type(shoplists) function, public compile_sl ( type(fndsv), intent(in)  myvfn)

Produce a vector of list of variables usefull for produce your request.

Parametri
[in]myvfnvector function object that solve the problem

Definizione alla linea 804 del file alchimia.F03.

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