libsim Versione 7.2.1

◆ 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 798 del file alchimia.F03.

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