libsim Versione 7.1.11
|
◆ compile_sl()Produce a vector of list of variables usefull for produce your request.
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
831
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
865 integer :: nin = imiss
866 integer :: nout = imiss
867 type(fnds),allocatable :: fnds(:)
869
872 CHARACTER(len=10),allocatable :: bvar(:)
874
877 type(shoplist),allocatable :: shoplist(:)
879
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
895 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
896end interface
897
900 module procedure fnv_delete
901end interface
902
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
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
1078 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
1080 print *,"function : ",fn%name," order :",fn%order
1082 print *,"function : ",fn%name," priority :",fn%priority
1083else
1084 print *,"function : ",fn%name
1085end if
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:"
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
1119 if (fnv%fnds(i)%order == order ) then
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
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")
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
1193 foundin = .true.
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
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
1222
1223!check if we have finish
1224allfoundout = .true.
1226 foundout = .false.
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
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.
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)
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
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
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
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
1348 !call display(vfntmp%fnds(i))
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
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)
1387 do j=1, size(mayvfn%fnds(i)%bout)
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
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
1461
1466
1469
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. Definition: array_utilities.F90:218 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:254 |