!! Copyright (C) Stichting Deltares, 2012-2014. !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License version 3, !! as published by the Free Software Foundation. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !! contact: delft3d.support@deltares.nl !! Stichting Deltares !! P.O. Box 177 !! 2600 MH Delft, The Netherlands !! !! All indications and logos of, and references to registered trademarks !! of Stichting Deltares remain the property of Stichting Deltares. All !! rights reserved. subroutine expand_frc ( lunrep, procesdef, allitems, sfracs) ! expand processes per fractions use processet use timers ! performance timers implicit none ! declaration of arguments integer :: lunrep ! report file type(procespropcoll) :: procesdef ! the process definition type(itempropcoll) :: allitems ! all items of the proces system type(sfracsprop) :: sfracs ! substance fraction properties ! local decalarations type(procesprop), pointer :: proc ! single process type(ioitemprop), pointer :: new_item(:) ! expanded list of items type(stochiprop), pointer :: new_stochi(:) ! expanded list of items type(itemprop) :: item ! one item integer :: nproc ! number of processes integer :: iproc ! loop counter processes integer :: isfrac ! index substance fractions integer :: isfrac2 ! index substance fractions integer :: nfrac ! number fractions in substance fraction character(len=20) :: basnam ! base name substance fractions character(len=20) :: fracnam ! name of substance fraction integer :: i_item ! index input item integer :: i_flux ! index flux item integer :: i_stochi ! index stochi integer :: indx ! index in list integer :: iret ! index in collection integer :: ifrac ! fraction number character(len=3) :: suffix ! suffix integer :: ierr_alloc ! error indication logical :: l_expand ! expand item list logical :: l_frac(sfracs%nsfrac) ! fraction involved in process integer :: no_input_new ! new number of items integer :: no_output_new ! new number of items integer :: no_fluxoutput_new ! new number of items integer :: no_fluxstochi_new ! new number of items integer :: no_velostochi_new ! new number of items integer :: no_dispstochi_new ! new number of items integer :: i_new ! index in new items integer :: isfrac_found ! index substance fractions integer :: i_star ! index of * in name integer :: nzoek ! nzoek integer(4) :: ithndl = 0 if (timon) call timstrt( "expand_frc", ithndl ) ! loop over the processes nproc = procesdef%cursize do iproc = 1, nproc proc => procesdef%procesprops(iproc) ! check for expansion and for the fractions involved l_expand = .false. l_frac = .false. do i_item = 1, proc%no_input if ( proc%input_item(i_item)%name(1:1) .eq. '*' ) then do isfrac = 1, sfracs%nsfrac basnam = sfracs%name(isfrac) call zoek( basnam, 1, proc%input_item(i_item)%name(2:), 19, indx) if ( indx .gt. 0 ) then l_expand = .true. l_frac(isfrac) = .true. exit endif enddo endif enddo if ( l_expand ) then ! count the dimensions of the expanded process no_input_new = proc%no_input do i_item = 1, proc%no_input ! check for the fractions itself do isfrac = 1, sfracs%nsfrac if ( l_frac(isfrac) ) then call zoek( sfracs%name(isfrac), 1, proc%input_item(i_item)%name, 20, indx) if ( indx .gt. 0 ) then no_input_new = no_input_new + sfracs%nfrac(isfrac) - 1 exit endif endif enddo ! check for input which needs to be expanded i_star = index(proc%input_item(i_item)%name,'*') if ( i_star .gt. 1 ) then do isfrac = 1, sfracs%nsfrac nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%input_item(i_item)%name(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then no_input_new = no_input_new + sfracs%nfrac(isfrac) - 1 exit endif enddo endif enddo no_output_new = proc%no_output do i_item = 1, proc%no_output i_star = index(proc%output_item(i_item)%name,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%output_item(i_item)%name(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then no_output_new = no_output_new + sfracs%nfrac(isfrac) - 1 exit endif enddo endif enddo no_fluxoutput_new = proc%no_fluxoutput do i_flux = 1, proc%no_fluxoutput i_star = index(proc%fluxoutput(i_flux)%name,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%fluxoutput(i_flux)%name(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then no_fluxoutput_new = no_fluxoutput_new + sfracs%nfrac(isfrac) - 1 exit endif enddo endif enddo no_fluxstochi_new = proc%no_fluxstochi do i_stochi = 1, proc%no_fluxstochi i_star = index(proc%fluxstochi(i_stochi)%ioitem,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nfrac = sfracs%nfrac(isfrac) basnam = sfracs%name(isfrac) nzoek = 20-i_star call zoek( basnam, 1, proc%fluxstochi(i_stochi)%ioitem(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then no_fluxstochi_new = no_fluxstochi_new + nfrac - 1 exit endif enddo endif enddo no_velostochi_new = proc%no_velostochi do i_item = 1, proc%no_velostochi i_star = index(proc%velostochi(i_item)%ioitem,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%velostochi(i_item)%ioitem(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then no_velostochi_new = no_velostochi_new + sfracs%nfrac(isfrac) - 1 exit endif enddo endif enddo no_dispstochi_new = proc%no_dispstochi do i_item = 1, proc%no_dispstochi i_star = index(proc%dispstochi(i_item)%ioitem,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%dispstochi(i_item)%ioitem(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then no_dispstochi_new = no_dispstochi_new + sfracs%nfrac(isfrac) - 1 exit endif enddo endif enddo ! then expand write(lunrep,2000) ' expanding fraction input for process [',proc%name,']' allocate(new_item(no_input_new)) i_new = 0 do i_item = 1, proc%no_input ! check for fraction (i_star = 0 then the substance fraction itself, i_star > 1 then process parameter) isfrac_found = 0 i_star = index(proc%input_item(i_item)%name,'*') do isfrac = 1, sfracs%nsfrac if ( l_frac(isfrac) ) then nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%input_item(i_item)%name(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then isfrac_found = isfrac exit endif endif enddo if ( i_star .eq. 1 ) then ! number of fractions i_new = i_new + 1 new_item(i_new) = proc%input_item(i_item) new_item(i_new)%indx = i_new if ( isfrac_found .gt. 0 ) then new_item(i_new)%actdef = sfracs%nfrac(isfrac_found) endif elseif ( isfrac_found .gt. 0 ) then ! expand input nfrac = sfracs%nfrac(isfrac_found) basnam = sfracs%name(isfrac_found) do ifrac = 1, nfrac if ( ifrac .lt. 100 ) then write(suffix,'(i2.2)') ifrac else write(suffix,'(i3.3)') ifrac endif fracnam = trim(basnam)//trim(suffix) i_new = i_new + 1 new_item(i_new) = proc%input_item(i_item) new_item(i_new)%indx = i_new if ( i_star .eq. 0 ) then new_item(i_new)%name = fracnam else new_item(i_new)%name = trim(proc%input_item(i_item)%name(1:i_star))//fracnam endif item%name = new_item(i_new)%name iret = itempropcollfind( allitems, item ) if ( iret .le. 0 ) then item%text = proc%input_item(i_item)%item%text item%default = proc%input_item(i_item)%item%default item%waqtype = proc%input_item(i_item)%item%waqtype iret = itempropcolladd( allitems, item ) endif new_item(i_new)%item=>allitems%itemproppnts(iret)%pnt enddo else ! just copy input i_new = i_new + 1 new_item(i_new) = proc%input_item(i_item) new_item(i_new)%indx = i_new endif enddo if (proc%no_input .gt. 0) deallocate(proc%input_item) proc%input_item => new_item proc%no_input = no_input_new ! output i_new = 0 allocate(new_item(no_output_new)) do i_item = 1, proc%no_output isfrac_found = 0 i_star = index(proc%output_item(i_item)%name,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%output_item(i_item)%name(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then isfrac_found = isfrac exit endif enddo endif if ( isfrac_found .gt. 0 ) then nfrac = sfracs%nfrac(isfrac_found) basnam = sfracs%name(isfrac_found) do ifrac = 1, nfrac if ( ifrac .lt. 100 ) then write(suffix,'(i2.2)') ifrac else write(suffix,'(i3.3)') ifrac endif fracnam = trim(basnam)//trim(suffix) i_new = i_new + 1 new_item(i_new) = proc%output_item(i_item) new_item(i_new)%indx = i_new new_item(i_new)%name = trim(proc%output_item(i_item)%name(1:i_star))//fracnam item%name = new_item(i_new)%name iret = itempropcollfind( allitems, item ) if ( iret .le. 0 ) then item%text = proc%output_item(i_item)%item%text item%default = proc%output_item(i_item)%item%default item%waqtype = proc%output_item(i_item)%item%waqtype iret = itempropcolladd( allitems, item ) endif new_item(i_new)%item=>allitems%itemproppnts(iret)%pnt enddo else i_new = i_new + 1 new_item(i_new) = proc%output_item(i_item) new_item(i_new)%indx = i_new endif enddo if (proc%no_output .gt. 0) deallocate(proc%output_item) proc%output_item => new_item proc%no_output = no_output_new ! fluxes i_new = 0 allocate(new_item(no_fluxoutput_new)) do i_item = 1, proc%no_fluxoutput isfrac_found = 0 i_star = index(proc%fluxoutput(i_item)%name,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nzoek = 20-i_star call zoek( sfracs%name(isfrac), 1, proc%fluxoutput(i_item)%name(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then isfrac_found = isfrac exit endif enddo endif if ( isfrac_found .gt. 0 ) then nfrac = sfracs%nfrac(isfrac_found) basnam = sfracs%name(isfrac_found) do ifrac = 1, nfrac if ( ifrac .lt. 100 ) then write(suffix,'(i2.2)') ifrac else write(suffix,'(i3.3)') ifrac endif fracnam = trim(basnam)//trim(suffix) i_new = i_new + 1 new_item(i_new) = proc%fluxoutput(i_item) new_item(i_new)%indx = i_new new_item(i_new)%name = trim(proc%fluxoutput(i_item)%name(1:i_star))//fracnam item%name = new_item(i_new)%name iret = itempropcollfind( allitems, item ) if ( iret .le. 0 ) then item%text = proc%fluxoutput(i_item)%item%text item%default = proc%fluxoutput(i_item)%item%default item%waqtype = proc%fluxoutput(i_item)%item%waqtype iret = itempropcolladd( allitems, item ) endif new_item(i_new)%item=>allitems%itemproppnts(iret)%pnt enddo else i_new = i_new + 1 new_item(i_new) = proc%fluxoutput(i_item) new_item(i_new)%indx = i_new endif enddo if (proc%no_fluxoutput .gt. 0) deallocate(proc%fluxoutput) proc%fluxoutput => new_item proc%no_fluxoutput = no_fluxoutput_new ! flux stochi i_new = 0 allocate(new_stochi(no_fluxstochi_new)) do i_stochi = 1, proc%no_fluxstochi i_star = index(proc%fluxstochi(i_stochi)%ioitem,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nfrac = sfracs%nfrac(isfrac) basnam = sfracs%name(isfrac) nzoek = 20-i_star call zoek( basnam, 1, proc%fluxstochi(i_stochi)%ioitem(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then isfrac_found = isfrac exit endif enddo if ( isfrac_found .gt. 0 ) then do ifrac = 1, nfrac if ( ifrac .lt. 100 ) then write(suffix,'(i2.2)') ifrac else write(suffix,'(i3.3)') ifrac endif fracnam = trim(basnam)//trim(suffix) i_new = i_new + 1 new_stochi(i_new) = proc%fluxstochi(i_stochi) new_stochi(i_new)%ioitem = trim(proc%fluxstochi(i_stochi)%ioitem(1:i_star))//fracnam call zoek (basnam,1,proc%fluxstochi(i_stochi)%substance,20,indx) if ( indx .gt. 0 ) then new_stochi(i_new)%substance = fracnam else ! look for linked substance (if not found the substance name stays the same do isfrac2 = 1, nfrac call zoek (sfracs%name(isfrac2),1,proc%fluxstochi(i_stochi)%substance,20,indx) if ( indx .gt. 0 .and. sfracs%linklist(isfrac,isfrac2) .eq. 1 ) then new_stochi(i_new)%substance = trim(sfracs%name(isfrac2))//suffix exit endif enddo endif enddo isfrac_found = 0 else i_new = i_new + 1 new_stochi(i_new) = proc%fluxstochi(i_stochi) endif else i_new = i_new + 1 new_stochi(i_new) = proc%fluxstochi(i_stochi) endif enddo if (proc%no_fluxstochi .gt. 0) deallocate(proc%fluxstochi) proc%fluxstochi => new_stochi proc%no_fluxstochi = no_fluxstochi_new ! disp stochi i_new = 0 allocate(new_stochi(no_dispstochi_new)) do i_stochi = 1, proc%no_dispstochi i_star = index(proc%dispstochi(i_stochi)%ioitem,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nfrac = sfracs%nfrac(isfrac) basnam = sfracs%name(isfrac) nzoek = 20-i_star call zoek( basnam, 1, proc%dispstochi(i_stochi)%ioitem(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then isfrac_found = isfrac exit endif enddo if ( isfrac_found .gt. 0 ) then do ifrac = 1, nfrac if ( ifrac .lt. 100 ) then write(suffix,'(i2.2)') ifrac else write(suffix,'(i3.3)') ifrac endif fracnam = trim(basnam)//trim(suffix) i_new = i_new + 1 new_stochi(i_new) = proc%dispstochi(i_stochi) new_stochi(i_new)%ioitem = trim(proc%dispstochi(i_stochi)%ioitem(1:i_star))//fracnam call zoek (basnam,1,proc%dispstochi(i_stochi)%substance,20,indx) if ( indx .gt. 0 ) then new_stochi(i_new)%substance = fracnam else ! look for linked substance (if not found the substance name stays the same do isfrac2 = 1, nfrac call zoek (sfracs%name(isfrac2),1,proc%dispstochi(i_stochi)%substance,20,indx) if ( indx .gt. 0 .and. sfracs%linklist(isfrac,isfrac2) .eq. 1 ) then new_stochi(i_new)%substance = trim(sfracs%name(isfrac2))//suffix exit endif enddo endif enddo isfrac_found = 0 else i_new = i_new + 1 new_stochi(i_new) = proc%dispstochi(i_stochi) endif else i_new = i_new + 1 new_stochi(i_new) = proc%dispstochi(i_stochi) endif enddo if (proc%no_dispstochi .gt. 0) deallocate(proc%dispstochi) proc%dispstochi => new_stochi proc%no_dispstochi = no_dispstochi_new ! velo stochi i_new = 0 allocate(new_stochi(no_velostochi_new)) do i_stochi = 1, proc%no_velostochi i_star = index(proc%velostochi(i_stochi)%ioitem,'*') if ( i_star .gt. 0 ) then do isfrac = 1, sfracs%nsfrac nfrac = sfracs%nfrac(isfrac) basnam = sfracs%name(isfrac) nzoek = 20-i_star call zoek( basnam, 1, proc%velostochi(i_stochi)%ioitem(i_star+1:), nzoek, indx) if ( indx .gt. 0 ) then isfrac_found = isfrac exit endif enddo if ( isfrac_found .gt. 0 ) then do ifrac = 1, nfrac if ( ifrac .lt. 100 ) then write(suffix,'(i2.2)') ifrac else write(suffix,'(i3.3)') ifrac endif fracnam = trim(basnam)//trim(suffix) i_new = i_new + 1 new_stochi(i_new) = proc%velostochi(i_stochi) new_stochi(i_new)%ioitem = trim(proc%velostochi(i_stochi)%ioitem(1:i_star))//fracnam call zoek (basnam,1,proc%velostochi(i_stochi)%substance,20,indx) if ( indx .gt. 0 ) then new_stochi(i_new)%substance = fracnam else ! look for linked substance (if not found the substance name stays the same do isfrac2 = 1, nfrac call zoek (sfracs%name(isfrac2),1,proc%velostochi(i_stochi)%substance,20,indx) if ( indx .gt. 0 .and. sfracs%linklist(isfrac,isfrac2) .eq. 1 ) then new_stochi(i_new)%substance = trim(sfracs%name(isfrac2))//suffix exit endif enddo endif enddo isfrac_found = 0 else i_new = i_new + 1 new_stochi(i_new) = proc%velostochi(i_stochi) endif else i_new = i_new + 1 new_stochi(i_new) = proc%velostochi(i_stochi) endif enddo if (proc%no_velostochi .gt. 0) deallocate(proc%velostochi) proc%velostochi => new_stochi proc%no_velostochi = no_velostochi_new endif enddo if (timon) call timstop( ithndl ) return 2000 format ( 3a ) end