libsim Versione 7.2.1
|
◆ compile_sl()Produce a vector of list of variables usefull for produce your request.
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
825
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
859 integer :: nin = imiss
860 integer :: nout = imiss
861 type(fnds),allocatable :: fnds(:)
863
866 CHARACTER(len=10),allocatable :: bvar(:)
868
871 type(shoplist),allocatable :: shoplist(:)
873
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
889 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
890end interface
891
894 module procedure fnv_delete
895end interface
896
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
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
1072 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
1074 print *,"function : ",fn%name," order :",fn%order
1076 print *,"function : ",fn%name," priority :",fn%priority
1077else
1078 print *,"function : ",fn%name
1079end if
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:"
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
1113 if (fnv%fnds(i)%order == order ) then
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
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")
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
1187 foundin = .true.
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
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
1216
1217!check if we have finish
1218allfoundout = .true.
1220 foundout = .false.
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
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.
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)
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
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
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
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
1342 !call display(vfntmp%fnds(i))
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
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)
1381 do j=1, size(mayvfn%fnds(i)%bout)
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
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
1455
1460
1463
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. Definition: array_utilities.F90:212 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:248 |