module SoybeanClass use, intrinsic :: iso_fortran_env use sim use SeedClass use LeafClass use RootClass use LightClass use PlantNodeClass use StemClass use FEMSolverClass use EnvironmentClass implicit none integer(int32), parameter :: PF_SOY_OBJECT_WISE = 1 type :: soybean_internode_info_ real(real64), allocatable :: FinalInterNodeLength(:) real(real64), allocatable :: FinalPetioleLength(:) real(real64), allocatable :: FinalLeafLength(:) real(real64), allocatable :: FinalLeafWidth(:) end type type :: soybean_NodeID_Branch_ integer(int32), allocatable :: ID(:) contains procedure, public :: sync => syncsoybean_NodeID_Branch end type integer(int32), parameter :: PF_DEFORMATION_ANALYSIS = 100 integer(int32), parameter :: PF_DEFAULT_SOYBEAN_ASIZE = 300 type :: soybean_ ! setting integer(int32) :: stem_division(1:3) = [3, 3, 30] integer(int32) :: peti_division(1:3) = [3, 3, 30] integer(int32) :: leaf_division(1:3) = [10, 1, 20] integer(int32) :: root_division(1:3) = [2, 2, 20] ! growth_habit = determinate, indeterminate, semi-indeterminate, or vine character*20 :: growth_habit character*2 :: growth_stage integer(int32) :: Num_Of_Node integer(int32) :: num_leaf integer(int32) :: num_stem_node integer(int32) :: Num_Of_Root integer(int32) :: TYPE_STEM = 1 integer(int32) :: TYPE_LEAF = 2 integer(int32) :: TYPE_ROOT = 3 integer(int32) :: MaxLeafNum = PF_DEFAULT_SOYBEAN_ASIZE integer(int32) :: MaxRootNum = PF_DEFAULT_SOYBEAN_ASIZE integer(int32) :: MaxStemNum = PF_DEFAULT_SOYBEAN_ASIZE logical :: determinate integer(int32) :: max_num_leaf_per_petiole = 3 ! as default integer(int32) :: ms_node, br_node(PF_DEFAULT_SOYBEAN_ASIZE), br_from(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: ms_length, br_length(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: ms_width, br_width(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: ms_angle_ave, br_angle_ave(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: ms_angle_sig, br_angle_sig(PF_DEFAULT_SOYBEAN_ASIZE) integer(int32) :: mr_node, brr_node(PF_DEFAULT_SOYBEAN_ASIZE), brr_from(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: mr_length, brr_length(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: mr_width, brr_width(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: mr_angle_ave, brr_angle_ave(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: mr_angle_sig, brr_angle_sig(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: peti_size_ave(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: peti_size_sig(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: peti_width_ave(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: peti_width_sig(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: peti_angle_ave(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: peti_angle_sig(PF_DEFAULT_SOYBEAN_ASIZE) real(real64) :: leaf_angle_ave(PF_DEFAULT_SOYBEAN_ASIZE*3) real(real64) :: leaf_angle_sig(PF_DEFAULT_SOYBEAN_ASIZE*3) real(real64) :: leaf_length_ave(PF_DEFAULT_SOYBEAN_ASIZE*3) real(real64) :: leaf_length_sig(PF_DEFAULT_SOYBEAN_ASIZE*3) real(real64) :: leaf_width_ave(PF_DEFAULT_SOYBEAN_ASIZE*3) real(real64) :: leaf_width_sig(PF_DEFAULT_SOYBEAN_ASIZE*3) real(real64) :: leaf_thickness_ave(PF_DEFAULT_SOYBEAN_ASIZE*3) real(real64) :: leaf_thickness_sig(PF_DEFAULT_SOYBEAN_ASIZE*3) character(3) :: Stage ! VE, CV, V1,V2, ..., R1, R2, ..., R8 character(200) :: name integer(int32)::stage_id = 0 real(real64) :: dt type(Seed_) :: Seed type(PlantNode_), allocatable :: NodeSystem(:) type(PlantRoot_), allocatable :: RootSystem(:) type(Stem_), allocatable :: Stem(:) type(Leaf_), allocatable :: Leaf(:) type(Root_), allocatable :: Root(:) ! material info real(real64), allocatable :: stemYoungModulus(:) real(real64), allocatable :: leafYoungModulus(:) real(real64), allocatable :: rootYoungModulus(:) real(real64), allocatable :: stemPoissonRatio(:) real(real64), allocatable :: leafPoissonRatio(:) real(real64), allocatable :: rootPoissonRatio(:) real(real64), allocatable :: stemDensity(:) real(real64), allocatable :: leafDensity(:) real(real64), allocatable :: rootDensity(:) ! 節-節点データ構造 type(Mesh_) :: struct integer(int32), allocatable :: leaf2stem(:, :) integer(int32), allocatable :: stem2stem(:, :) integer(int32), allocatable :: root2stem(:, :) integer(int32), allocatable :: root2root(:, :) ! 器官オブジェクト配列 (regacy) type(FEMDomain_), allocatable :: leaf_list(:) type(FEMDomain_), allocatable :: stem_list(:) type(FEMDomain_), allocatable :: root_list(:) ! シミュレータ type(ContactMechanics_) :: contact real(real64) :: time real(real64) :: seed_length real(real64) :: seed_width real(real64) :: seed_height real(real64), allocatable :: stem_angle(:, :) real(real64), allocatable :: root_angle(:, :) real(real64), allocatable :: leaf_angle(:, :) character(200) :: stemconfig = "" character(200) :: rootconfig = "" character(200) :: leafconfig = "" ! for deformation analysis logical :: property_deform_material_density = .false. logical :: property_deform_material_YoungModulus = .false. logical :: property_deform_material_PoissonRatio = .false. logical :: property_deform_material_CarbonDiffusionCoefficient = .false. logical :: property_deform_initial_Displacement = .false. logical :: property_deform_initial_Stress = .false. logical :: property_deform_boundary_TractionForce = .false. logical :: property_deform_boundary_Displacement = .false. logical :: property_deform_gravity = .false. real(real64) :: Gravity_acceralation = 9.810d0 real(real64) :: PenaltyParameter = 100000.0d0 logical :: GaussPointProjection = .false. integer(int32), allocatable :: NodeID_MainStem(:) type(soybean_NodeID_Branch_), allocatable :: NodeID_Branch(:) logical :: inLoop = .false. real(real64) :: hours = 0.0d0 ! growth simulation real(real64) :: FullyExpanded_stem_threshold = 0.10d0 integer(int32) :: MaxBranchNum = 20 type(soybean_internode_info_), allocatable :: InterNodeInfo(:) real(real64) :: default_Leaf_growth_ratio = 1.0d0/3.0d0 real(real64) :: default_Stem_growth_ratio = 1.0d0/3.0d0 integer(int32), allocatable :: MainStem_num_branch(:) real(real64) :: apical_dominance_distance = 1.0d0 ! create CV real(real64) :: CV_stem_length_ave = 0.03d0 real(real64) :: CV_stem_length_sig = 0.001d0 real(real64) :: CV_stem_width_ave = 0.003d0 real(real64) :: CV_stem_width_sig = 0.00001d0 real(real64) :: CV_leaf_length_ave = 0.03d0 real(real64) :: CV_leaf_length_sig = 0.001d0 real(real64) :: CV_leaf_width_ave = 0.02d0 real(real64) :: CV_leaf_width_sig = 0.0005d0 real(real64) :: CV_leaf_thickness_ave = 0.005d0 real(real64) :: CV_leaf_thickness_sig = 0.0001d0 real(real64) :: VC_stem_length_ave = 0.04d0 real(real64) :: VC_stem_length_sig = 0.001d0 real(real64) :: VC_stem_width_ave = 0.004d0 real(real64) :: VC_stem_width_sig = 0.0001d0 real(real64) :: VC_leaf_length_ave = 0.03d0 real(real64) :: VC_leaf_length_sig = 0.001d0 real(real64) :: VC_leaf_width_ave = 0.03d0 real(real64) :: VC_leaf_width_sig = 0.0005d0 real(real64) :: VC_leaf_thickness_ave = 0.001d0 real(real64) :: VC_leaf_thickness_sig = 0.00001d0 character(36) :: UUID ! carbon flow and photosynthesis ! carbon concentration (micro-gram/m^3) at apical real(real64) :: apical_carbon_concentration = 0.01d0 real(real64), allocatable :: Photosynthate_n(:), reaction_n(:) contains !procedure,public :: addRoot => addRootSoybean !procedure,public :: addLeaf => addLeafSoybean ! creation procedure, pass :: initsoybean procedure, pass :: init_as_seed_soybean generic :: init => initsoybean,init_as_seed_soybean procedure, public :: VC => VCSoybean procedure, public :: remove => removeSoybean procedure, public :: create => initsoybean procedure, public :: new => initsoybean procedure, public :: sowing => initsoybean procedure, public :: export => exportSoybean procedure, public :: expanition => expanitionSoybean procedure, public :: development => developmentSoybean ! Simulator procedure, public :: checkProperties => checkPropertiesSoybean procedure, public :: setPoints => setPointsSoybean procedure, public :: setProperties => setPropertiesSoybean ! editor procedure, public :: set_stem_length_by_list => set_stem_length_by_list_Soybean procedure, public :: set_stem_angle_by_list => set_stem_angle_by_list_Soybean ! simple setters procedure, public :: addStem => addStemSoybean procedure, public :: setPropertiesDensity => setPropertiesDensitySoybean procedure, public :: setPropertiesYoungModulus => setPropertiesYoungModulusSoybean procedure, public :: setPropertiesPoissonRatio => setPropertiesPoissonRatioSoybean procedure, public :: setPropertiesInitialDisplacement => setPropertiesInitialDisplacementSoybean procedure, public :: setPropertiesInitialStress => setPropertiesInitialStressSoybean procedure, public :: setPropertiesBoundaryTractionForce => setPropertiesBoundaryTractionForceSoybean procedure, public :: setPropertiesBoundaryDisplacement => setPropertiesBoundaryDisplacementSoybean procedure, public :: setPropertiesGravity => setPropertiesGravitySoybean procedure, public :: setFEMDomains => setFEMDomainsSoybean procedure, public :: setFEMDomain => setFEMDomainsSoybean ! alternative setters procedure, public :: setYoungModulus => setYoungModulusSoybean procedure, public :: setPoissonRatio => setPoissonRatioSoybean procedure, public :: setDensity => setDensitySoybean procedure, public :: runSimulation => runSimulationSoybean procedure, public :: runSimulator => runSimulationSoybean ! readyForSoybean procedure, public :: readyFor => readyForSoybean ! observation/info procedure, public :: stemlength => stemlengthSoybean procedure, public :: NumberOfBranch => NumberOfBranchSoybean procedure, public :: isMainStem => isMainStemSoybean procedure, public :: isBranchStem => isBranchStemSoybean procedure, public :: checkYoungModulus => checkYoungModulusSoybean procedure, public :: checkPoissonRatio => checkPoissonRatioSoybean procedure, public :: checkDensity => checkDensitySoybean procedure, public :: checkMemoryRequirement => checkMemoryRequirementSoybean procedure, public :: getYoungModulus => getYoungModulusSoybean procedure, public :: getPoissonRatio => getPoissonRatioSoybean procedure, public :: getDensity => getDensitySoybean procedure, public :: getVertices => getVerticesSoybean procedure, public :: getYoungModulusField => getYoungModulusFieldSoybean procedure, public :: getPoissonRatioField => getPoissonRatioFieldSoybean procedure, public :: getDensityField => getDensityFieldSoybean procedure, public :: getDiffusionCoefficient => getDiffusionCoefficientSoybean ! these two functions are different!!! ! get [obj_idx(:),obj_type(:),local element idx(:)] procedure, public :: getElementList => getElementListSoybean ! get global Element Idx procedure, public :: getGlobalElementIdx => getGlobalElementIdxSoybean ! stem length, stem angles procedure, public :: get_stem_length_list => get_stem_length_list_Soybean procedure, public :: get_stem_angle_list => get_stem_angle_list_Soybean procedure, public :: MassMatrix => MassMatrixSoybean procedure, public :: StiffnessMatrix => StiffnessMatrixSoybean ! operation procedure, public :: findApical => findApicalSoybean procedure, public :: grow => growSoybean procedure, public :: getVolume => getVolumeSoybean procedure, public :: getVolumePerElement => getVolumePerElementSoybean procedure, public :: getBioMass => getBioMassSoybean procedure, public :: getElementBiomass => getElementBiomassSoybean procedure, public :: getTotalWeight => getTotalWeightSoybean procedure, public :: getSubDomain => getSubDomainSoybean procedure, public :: getSubDomainType => getSubDomainTypeSoybean procedure, public :: setSubDomain => setSubDomainSoybean procedure, public :: getPoints => getPointsSoybean procedure, public :: getRadius => getRadiusSoybean procedure, public :: getCenter => getCenterSoybean procedure, public :: getDistanceFromGround => getDistanceFromGroundSoybean procedure, public :: getNumberOfPoint => getNumberOfPointSoybean procedure, public :: getNumberOfElement => getNumberOfElementSoybean procedure, public :: getDistanceToGroundFromStemID & => getDistanceToGroundFromStemIDSoybean procedure, public :: getDistanceToGroundFromRootID & => getDistanceToGroundFromRootIDSoybean procedure, public :: getLeafCosValue => getLeafCosValueSoybean procedure, public :: getRangeOfNodeID => getRangeOfNodeIDSoybean procedure, public :: getFEMDomainPointers => getFEMDomainPointersSoybean procedure, public :: fall_leaf => fall_leafSoybean procedure, public :: getFEMDomains => to_FEMDomainsSoybean procedure, public :: to_FEMDomains => to_FEMDomainsSoybean ! >> simulation procedure, public :: getPPFD => getPPFDSoybean procedure, public :: getSpectrum => getSpectrumSoybean procedure, public :: to_R_FR => to_R_FRSoybean procedure, public :: getDisplacement => getDisplacementSoybean procedure, public :: getEigenMode => getEigenModeSoybean procedure, pass :: getPhotoSynthesisSoybean procedure, pass :: getPhotoSynthesis_by_env_soybean generic :: getPhotoSynthesis => getPhotoSynthesis_by_env_soybean, getPhotoSynthesisSoybean procedure, public :: getPhotoSynthesisSpeedPerVolume => getPhotoSynthesisSpeedPerVolumeSoybean procedure, public :: getLeafArea => getLeafAreaSoybean procedure, public :: getIntersectLeaf => getIntersectLeafSoybean procedure, public :: getOverwrapLeaf => getIntersectLeafSoybean procedure, public :: searchStem => searchStemSoybean procedure, public :: searchPetiole => searchPetioleSoybean procedure, public :: searchLeaf => searchLeafSoybean ! post-processing procedure, public :: export_eig => export_eigSoybean procedure, public :: getStressField => getStressFieldSoybean ! max *** ID procedure, public :: maxleafID => maxleafIDSoybean procedure, public :: maxInterNodeID => maxInterNodeIDSoybean procedure, public :: maxPetioleID => maxPetioleIDSoybean procedure, public :: maxStemID => maxStemIDSoybean ! data-format converter procedure, public :: convertDataFormat => convertDataFormatSoybean procedure, public :: fixReversedElements => fixReversedElementsSoybean procedure, public :: resize => resizeSoybean procedure, public :: deform => deformSoybean ! MPI procedure, public :: sync => syncSoybean ! visualization procedure, public :: show => showSoybean procedure, public :: gmsh => gmshSoybean procedure, public :: msh => mshSoybean procedure, public :: vtk => vtkSoybean procedure, public :: stl => stlSoybean procedure, public :: ply => plySoybean procedure, public :: json => jsonSoybean ! get info !procedure,public :: properties => propertiesSoybean ! number of subdomain procedure, public :: ns => nsSoybean ! number of element procedure, public :: ne => neSoybean ! number of points procedure, public :: nn => nnSoybean procedure, public :: np => nnSoybean procedure, public :: branchID => branchIDSoybean ! range of pointIDs for [Organ type, ID] procedure, public :: nn_range => nn_rangeSoybean ! observe procedure,public :: height => height_Soybean procedure,public :: xmin => x_min_Soybean procedure,public :: x_min => x_min_Soybean procedure,public :: ymin => y_min_Soybean procedure,public :: y_min => y_min_Soybean procedure,public :: zmin => z_min_Soybean procedure,public :: z_min => z_min_Soybean procedure,public :: xmax => x_max_Soybean procedure,public :: x_max => x_max_Soybean procedure,public :: ymax => y_max_Soybean procedure,public :: y_max => y_max_Soybean procedure,public :: zmax => z_max_Soybean procedure,public :: z_max => z_max_Soybean ! regacy/experimental procedure, public :: WaterAbsorption => WaterAbsorptionSoybean procedure, public :: move => moveSoybean procedure, public :: rotate => rotateSoybean procedure, public :: numleaf => numleafsoybean procedure, public :: numstem => numstemsoybean procedure, public :: numroot => numrootsoybean procedure, public :: laytracing => laytracingsoybean procedure, public :: SinkSourceFlow => SinkSourceFlowSoybean procedure, public :: update => updateSoybean procedure, public :: updateFlowers => updateFlowersSoybean procedure, public :: updatePods => updatePodsSoybean procedure, public :: AddNode => AddNodeSoybean procedure, public :: AddPhytomere => AddNodeSoybean ! structure editor/analyzer procedure, pass :: resizeStem => resizeStemSoybean procedure, pass :: rotateStem => rotateStemSoybean procedure, pass :: resizePetiole => resizePetioleSoybean procedure, pass :: rotatePetiole => rotatePetioleSoybean procedure, pass :: resizeLeaf => resizeLeafSoybean ! growth parameters procedure, pass :: setFinalInterNodeLength => setFinalInterNodeLengthSoybean procedure, pass :: setFinalPetioleLength => setFinalPetioleLengthSoybean procedure, pass :: setFinalLeafLength => setFinalLeafLengthSoybean procedure, pass :: setFinalLeafWidth => setFinalLeafWidthSoybean ! converter procedure, public :: ElementID2NodeID => ElementID2NodeIDSoybean ! essential routines for growth simulation procedure, pass :: getcarbon_concentration => getCarbon_concentrationSoybean procedure, pass :: getRespiration => getRespirationSoybean procedure, pass :: getCarbonFlow => getCarbonFlowSoybean end type type :: soybeanp_ type(soybean_), pointer :: soybeanp => null() end type type :: SoybeanCanopy_ real(real64) :: inter_row, intra_row type(soybean_), allocatable :: Canopy(:, :) end type contains ! subroutine VCSoybean(this) class(Soybean_), intent(inout) :: this type(Random_) :: random integer(int32) :: i real(real64) :: y_val, z_val, x_val, leaf_z_angles(4) !initialize call print("[WARNING] soybean % VC() is deprecated,") call this%remove() ! set default parameters ! set default parameters ! stem this%br_node(:) = 0 this%br_from(:) = 0 this%br_length(:) = 0.0d0 this%br_angle_ave(:) = 0.0d0 this%br_angle_sig(:) = 10.0d0 !this%br_angle_ave(1)=10.0d0 !this%br_angle_sig(1)=2.0d0 this%ms_angle_ave = 0.0d0 this%ms_angle_sig = 2.0d0 ! for roots this%brr_node(:) = 0 this%brr_from(:) = 0 this%brr_length(:) = 0.0d0 this%brr_angle_ave(:) = 0.0d0 this%brr_angle_sig(:) = 10.0d0 this%brr_angle_ave(1) = 30.0d0 this%brr_angle_sig(1) = 2.0d0 this%mr_angle_ave = 0.0d0 this%mr_angle_sig = 2.0d0 ! peti ! is also stem this%peti_size_ave(:) = 0.20d0 this%peti_size_sig(:) = 0.010d0 this%peti_width_ave(:) = 0.0050d0 this%peti_width_sig(:) = 0.00010d0 this%peti_angle_ave(:) = 30.0d0 this%peti_angle_sig(:) = 1.00d0 ! leaf this%leaf_length_ave(:) = 0.20d0 this%leaf_length_sig(:) = 0.01d0 this%leaf_width_ave(:) = 0.050d0 this%leaf_width_sig(:) = 0.010d0 this%leaf_thickness_ave(:) = 0.00100d0 this%leaf_thickness_sig(:) = 0.00050d0 this%leaf_angle_ave(:) = 80.0d0 this%leaf_angle_sig(:) = 10.0d0 allocate (this%leaf(this%MaxLeafNum)) allocate (this%root(this%MaxrootNum)) allocate (this%stem(this%MaxstemNum)) allocate (this%leafYoungModulus(this%MaxLeafNum)) allocate (this%rootYoungModulus(this%MaxrootNum)) allocate (this%stemYoungModulus(this%MaxstemNum)) ! default value this%leafYoungModulus(:) = 1000.0d0 this%rootYoungModulus(:) = 1000.0d0 this%stemYoungModulus(:) = 1000.0d0 allocate (this%leafPoissonRatio(this%MaxLeafNum)) allocate (this%rootPoissonRatio(this%MaxrootNum)) allocate (this%stemPoissonRatio(this%MaxstemNum)) this%leafPoissonRatio(:) = 0.30d0 this%rootPoissonRatio(:) = 0.30d0 this%stemPoissonRatio(:) = 0.30d0 allocate (this%leafDensity(this%MaxLeafNum)) allocate (this%rootDensity(this%MaxrootNum)) allocate (this%stemDensity(this%MaxstemNum)) this%leafDensity(:) = 0.0d0 this%rootDensity(:) = 0.0d0 this%stemDensity(:) = 0.0d0 allocate (this%stem2stem(this%MaxstemNum, this%MaxstemNum)) allocate (this%leaf2stem(this%MaxstemNum, this%MaxLeafNum)) allocate (this%root2stem(this%MaxrootNum, this%MaxstemNum)) allocate (this%root2root(this%MaxrootNum, this%MaxrootNum)) this%stem2stem(:, :) = 0 this%leaf2stem(:, :) = 0 this%root2stem(:, :) = 0 this%root2root(:, :) = 0 ! create VC plant ! create stage CV this%NodeID_MainStem = eyes(1) call this%stem(1)%init() this%stem(1)%stemID = 0 this%stem(1)%InterNodeID = 1 this%stem(1)%already_grown = .true. call this%stem(1)%resize( & x=random%gauss(mu=this%CV_stem_width_ave, sigma=this%CV_stem_width_sig), & y=random%gauss(mu=this%CV_stem_width_ave, sigma=this%CV_stem_width_sig), & z=random%gauss(mu=this%CV_stem_length_ave, sigma=this%CV_stem_length_sig) & ) call this%stem(1)%move( & x=-this%stem(1)%femdomain%xmax()/2.0d0, & y=-this%stem(1)%femdomain%ymax()/2.0d0, & z=0.0d0 & ) call this%stem(1)%rotate( & z=radian(360.0d0*random%random()) & ) ! end of primary growth this%stem(1)%already_grown = .true. leaf_z_angles(1) = random%random()*360.0d0 leaf_z_angles(2) = leaf_z_angles(1) + 180.0d0 leaf_z_angles(3) = random%random()*360.0d0 leaf_z_angles(4) = leaf_z_angles(3) + 180.0d0 this%num_leaf = 0 do i = 1, 2 this%num_leaf = this%num_leaf + 1 call this%leaf(i)%init(species=PF_SOYBEAN_CV) y_val = random%gauss(mu=this%CV_leaf_thickness_ave, sigma=this%CV_leaf_thickness_sig) z_val = random%gauss(mu=this%CV_leaf_length_ave, sigma=this%CV_leaf_length_sig) x_val = random%gauss(mu=this%CV_leaf_width_ave, sigma=this%CV_leaf_width_sig) this%leaf(i)%already_grown = .true. call this%leaf(i)%resize( & y=y_val, & z=z_val, & x=x_val & ) call this%leaf(i)%move( & y=-y_val/2.0d0, & z=-z_val/2.0d0, & x=-x_val/2.0d0 & ) call this%leaf(i)%rotate( & x=radian(90.0d0), & y=0.0d0, & z=radian(leaf_z_angles(i)), reset=.true. & ) call this%leaf(i)%connect("=>", this%stem(1)) this%leaf2stem(i, 1) = 1 end do call this%update() ! create stage VC if (allocated(this%NodeID_Branch)) then deallocate (this%NodeID_Branch) end if this%NodeID_MainStem = this%NodeID_MainStem//[2] call this%stem(2)%init() this%stem(2)%stemID = 0 this%stem(2)%InterNodeID = 1 this%stem(2)%already_grown = .true. call this%stem(2)%resize( & x=random%gauss(mu=this%VC_stem_width_ave, sigma=this%VC_stem_width_sig), & y=random%gauss(mu=this%VC_stem_width_ave, sigma=this%VC_stem_width_sig), & z=random%gauss(mu=this%VC_stem_length_ave, sigma=this%VC_stem_length_sig) & ) call this%stem(2)%move( & x=-this%stem(2)%femdomain%xmax()/2.0d0, & y=-this%stem(2)%femdomain%ymax()/2.0d0, & z=0.0d0 & ) call this%stem(2)%rotate( & z=radian(360.0d0*random%random()) & ) ! end of primary growth this%stem(2)%already_grown = .true. this%stem2stem(2, 1) = 1 do i = 3, 4 this%num_leaf = this%num_leaf + 1 call this%leaf(i)%init(SoyWidthRatio=0.50d0) y_val = random%gauss(mu=this%VC_leaf_thickness_ave, sigma=this%VC_leaf_thickness_sig) z_val = random%gauss(mu=this%VC_leaf_length_ave, sigma=this%VC_leaf_length_sig) x_val = random%gauss(mu=this%VC_leaf_width_ave, sigma=this%VC_leaf_width_sig) this%leaf(i)%already_grown = .true. call this%leaf(i)%resize( & y=y_val, & z=z_val, & x=x_val & ) call this%leaf(i)%move( & y=-y_val/2.0d0, & z=-z_val/2.0d0, & x=-x_val/2.0d0 & ) call this%leaf(i)%rotate( & x=radian(90.0d0), & y=0.0d0, & z=radian(leaf_z_angles(i)), reset=.true. & ) call this%leaf(i)%connect("=>", this%stem(2)) this%leaf2stem(i, 2) = 1 end do call this%update() ! no root this%stem2stem(2, 1) = 1 end subroutine ! ######################################## recursive subroutine updateSoybean(obj, stem_id, root_id, leaf_id, overset_margin, debug) class(Soybean_), intent(inout) :: obj integer(int32), optional, intent(in) :: stem_id, root_id, leaf_id real(real64), optional, intent(in) :: overset_margin integer(int32) :: i, j, this_stem_id, next_stem_id, A_id, B_id, itr_tol, itr, k, kk integer(int32) :: this_leaf_id, next_leaf_id integer(int32) :: this_root_id, next_root_id, InterNodeID, PetioleID, StemID, LeafID real(real64) :: x_A(3), x_B(3), diff(3), error, last_error, mgn, overset_m, error_tol,original_position(1:3),disp(1:3) logical, optional, intent(in) :: debug original_position = obj%stem(1)%femdomain%mesh%nodcoord(1,3) if (obj%default_Leaf_growth_ratio > 0.0d0) then do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) cycle obj%leaf(i)%length_growth_ratio = obj%default_Leaf_growth_ratio obj%leaf(i)%Width_growth_ratio = obj%default_Leaf_growth_ratio end do end if if (obj%default_stem_growth_ratio > 0.0d0) then do i = 1, size(obj%stem) if (obj%stem(i)%empty()) cycle obj%stem(i)%length_growth_ratio = obj%default_stem_growth_ratio obj%stem(i)%Width_growth_ratio = obj%default_stem_growth_ratio end do end if ! if soybean_internode_info_ is active ! update parameters if (allocated(obj%InterNodeInfo)) then do i = 0, obj%MaxBranchNum if (allocated(obj%InterNodeInfo(i)%FinalInterNodeLength)) then do j = 1, obj%maxInterNodeID(StemID=i) InterNodeID = obj%searchStem(StemID=i, InterNodeID=j) if (size(obj%InterNodeInfo(i)%FinalInterNodeLength) < j) then print *, "ERROR :: updateSoybean >> " print *, "size(obj%InterNodeInfo(i)%FinalInterNodeLength) is not enough" stop end if if (InterNodeID < 1) then cycle end if obj%stem(InterNodeID)%final_length = obj%InterNodeInfo(i)%FinalInterNodeLength(j) end do end if if (allocated(obj%InterNodeInfo(i)%FinalPetioleLength)) then do j = 1, obj%maxInterNodeID(StemID=i) do k = 1, obj%maxPetioleID(StemID=i, InterNodeID=j) if (size(obj%InterNodeInfo(i)%FinalPetioleLength) < j) then print *, "ERROR :: updateSoybean >> " print *, "size(obj%InterNodeInfo(i)%FinalInterNodeLength) is not enough" stop end if PetioleID = obj%searchPetiole(StemID=i, InterNodeID=j, PetioleID=k) obj%stem(PetioleID)%final_length = obj%InterNodeInfo(i)%FinalPetioleLength(j) end do end do end if if (allocated(obj%InterNodeInfo(i)%FinalLeafLength)) then do j = 1, obj%maxInterNodeID(StemID=i) do k = 1, obj%maxPetioleID(StemID=i, InterNodeID=j) do kk = 1, obj%maxleafID(StemID=i, InterNodeID=j, PetioleID=k) if (size(obj%InterNodeInfo(i)%FinalLeafLength) < j) then print *, "ERROR :: updateSoybean >> " print *, "size(obj%InterNodeInfo(i)%FinalInterNodeLength) is not enough" stop end if LeafID = obj%searchleaf(StemID=i, InterNodeID=j, PetioleID=k, LeafID=kk) obj%leaf(LeafID)%final_length = obj%InterNodeInfo(i)%FinalLeafLength(j) end do end do end do end if if (allocated(obj%InterNodeInfo(i)%FinalLeafWidth)) then do j = 1, obj%maxInterNodeID(StemID=i) do k = 1, obj%maxPetioleID(StemID=i, InterNodeID=j) do kk = 1, obj%maxleafID(StemID=i, InterNodeID=j, PetioleID=k) if (size(obj%InterNodeInfo(i)%FinalLeafWidth) < j) then print *, "ERROR :: updateSoybean >> " print *, "size(obj%InterNodeInfo(i)%FinalInterNodeLength) is not enough" stop end if LeafID = obj%searchleaf(StemID=i, InterNodeID=j, PetioleID=k, LeafID=kk) obj%leaf(LeafID)%final_Width = obj%InterNodeInfo(i)%FinalLeafWidth(j) end do end do end do end if end do end if ! update connectivity if (.not. allocated(obj%stem2stem)) then print *, "updateSoybean >> ERROR :: .not. allocated(obj%stem2stem )" return end if error_tol = dble(1.0e-14) ! margin between subdomains overset_m = input(default=0.03d0, option=overset_margin) itr_tol = 1000 itr = 0 ! if debug !if(present(debug) )then ! if(debug)then ! print *, "obj%stem2stem" ! call print(obj%stem2stem) ! endif !endif ! stem to stem last_error = 1.0d0 if (maxval(obj%stem2stem) /= 0) then do itr = itr + 1 error = 0.0d0 do i = 1, size(obj%stem2stem, 1) do j = 1, size(obj%stem2stem, 2) this_stem_id = j next_stem_id = i if (obj%stem2stem(i, j) /= 0 .and. i /= j) then ! this_stem_id ===>>> next_stem_id, connected! !x_B(:) = obj%stem(this_stem_id)%getCoordinate("B") !x_A(:) = obj%stem(next_stem_id)%getCoordinate("A") ! Overset分食い込ませる x_B(:) = (1.0d0 - overset_m)*obj%stem(this_stem_id)%getCoordinate("B") & + overset_m*obj%stem(this_stem_id)%getCoordinate("A") ! Overset分食い込ませる x_A(:) = (1.0d0 - overset_m)*obj%stem(next_stem_id)%getCoordinate("A") & + overset_m*obj%stem(next_stem_id)%getCoordinate("B") diff(:) = x_B(:) - x_A(:) error = error + dot_product(diff, diff) call obj%stem(next_stem_id)%move(x=diff(1), y=diff(2), z=diff(3)) end if end do end do if (present(debug)) then if (debug) then print *, "soybean % update s2s >> error :: ", error end if end if if (itr > itr_tol) then print *, "soybean % update s2s >> ERROR :: not converged" stop end if if (abs(error) + abs(last_error) < error_tol) exit last_error = error end do end if ! root to stem if (allocated(obj%root2stem)) then last_error = 1.0d0 do itr = itr + 1 error = 0.0d0 do i = 1, size(obj%root2stem, 1) do j = 1, size(obj%root2stem, 2) this_stem_id = j next_root_id = i if (obj%root2stem(i, j) == 1) then ! this_stem_id ===>>> next_root_id, connected! !x_B(:) = obj%stem(this_stem_id)%getCoordinate("B") !x_A(:) = obj%root(next_root_id)%getCoordinate("A") ! Overset分食い込ませる x_B(:) = (1.0d0 - overset_m)*obj%stem(this_stem_id)%getCoordinate("A") & + overset_m*obj%stem(this_stem_id)%getCoordinate("B") ! Overset分食い込ませる x_A(:) = (1.0d0 - overset_m)*obj%root(next_root_id)%getCoordinate("A") & + overset_m*obj%root(next_root_id)%getCoordinate("B") diff(:) = x_B(:) - x_A(:) error = error + dot_product(diff, diff) call obj%root(next_root_id)%move(x=diff(1), y=diff(2), z=diff(3)) end if end do end do if (present(debug)) then if (debug) then print *, "soybean % update r2s >> error :: ", error end if end if if (itr > itr_tol) then print *, "soybean % update r2s >> ERROR :: not converged" stop end if if (abs(error) + abs(last_error) < error_tol) exit last_error = error end do end if if (allocated(obj%root2root)) then ! root to root last_error = 1.0d0 do itr = itr + 1 error = 0.0d0 do i = 1, size(obj%root2root, 1) do j = 1, size(obj%root2root, 2) this_root_id = j next_root_id = i if (next_root_id == 1) then cycle end if if (obj%root2root(i, j) /= 0 .and. i /= j) then ! this_root_id ===>>> next_root_id, connected! !x_B(:) = obj%root(this_root_id)%getCoordinate("B") !x_A(:) = obj%root(next_root_id)%getCoordinate("A") ! Overset分食い込ませる x_B(:) = (1.0d0 - overset_m)*obj%root(this_root_id)%getCoordinate("B") & + overset_m*obj%root(this_root_id)%getCoordinate("A") ! Overset分食い込ませる x_A(:) = (1.0d0 - overset_m)*obj%root(next_root_id)%getCoordinate("A") & + overset_m*obj%root(next_root_id)%getCoordinate("B") diff(:) = x_B(:) - x_A(:) error = error + dot_product(diff, diff) call obj%root(next_root_id)%move(x=diff(1), y=diff(2), z=diff(3)) end if end do end do if (present(debug)) then if (debug) then print *, "soybean % update r2r >> error :: ", error end if end if if (itr > itr_tol) then print *, "soybean % update r2r >> ERROR :: not converged" stop end if if (abs(error) + abs(last_error) < error_tol) exit last_error = error end do end if ! leaf to stem last_error = 1.0d0 do itr = itr + 1 error = 0.0d0 do i = 1, size(obj%leaf2stem, 1) do j = 1, size(obj%leaf2stem, 2) this_stem_id = j next_leaf_id = i if (obj%leaf2stem(i, j) == 1) then ! this_stem_id ===>>> next_leaf_id, connected! !x_B(:) = obj%stem(this_stem_id)%getCoordinate("B") !x_A(:) = obj%leaf(next_leaf_id)%getCoordinate("A") ! Overset分食い込ませる x_B(:) = (1.0d0 - overset_m)*obj%stem(this_stem_id)%getCoordinate("B") & + overset_m*obj%stem(this_stem_id)%getCoordinate("A") ! Overset分食い込ませる x_A(:) = obj%leaf(next_leaf_id)%getCoordinate("A") diff(:) = x_B(:) - x_A(:) error = error + dot_product(diff, diff) call obj%leaf(next_leaf_id)%move(x=diff(1), y=diff(2), z=diff(3)) end if end do end do if (present(debug)) then if (debug) then print *, "soybean % update l2s >> error :: ", error end if end if if (itr > itr_tol) then print *, "soybean % update l2s >> ERROR :: not converged" stop end if if (abs(error) - abs(last_error) < error_tol) exit last_error = error end do ! offset displacement !if ( norm(obj%stem(1)%femdomain%mesh%nodcoord(1,3) - original_position) > error_tol)then ! disp = obj%stem(1)%femdomain%mesh%nodcoord(1,3) - original_position ! call obj%move(x=-disp(1),y=-disp(2),z=-disp(3)) !endif end subroutine ! ######################################## ! ######################################## subroutine initsoybean(obj, config, & regacy, mass, water_content, radius, location, x, y, z, & PlantRoot_diameter_per_seed_radius, max_PlantNode_num, Variety, FileName, & max_leaf_num, max_stem_num, max_root_num, profiler) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: mass, water_content, radius, location(3), x, y, z real(real64), optional, intent(in) :: PlantRoot_diameter_per_seed_radius character(*), optional, intent(in) :: Variety, FileName, config logical, optional, intent(in) :: regacy, profiler character(:), allocatable :: fn, conf, line integer(int32), optional, intent(in) :: max_PlantNode_num, max_leaf_num, max_stem_num, max_root_num real(real64) :: MaxThickness, Maxwidth, loc(3), vec(3), rot(3), zaxis(3), meshloc(3), meshvec(3), & x_val, y_val, z_val integer(int32) :: i, j, k, blcount, id, rmc, n, node_id, node_id2, elemid, branch_id, num_stem_node real(real64)::readvalreal real(real64), allocatable :: leaf_z_angles(:) integer(int32) :: readvalint logical :: debug = .false. logical :: timeOpt = .false. type(IO_) :: soyconf type(Random_) :: random type(Time_) :: time type(Stem_) :: stem type(Leaf_) :: leaf type(Root_) :: root real(real64) :: seed_width,seed_length,seed_thickness integer(int32) :: seed_division obj%UUID = generate_uuid(1) timeOpt = input(default=.false., option=profiler) ! IS THIS A SEED? if (present(config))then !if ("Seed" .in. keys(json_file=config)) then if (.not. ( "{'not found'}" .in. soyconf%parse_json(filename=config, & keys=to_list("Seed","Length")) ) ) then seed_length = soyconf%parse_json(filename=config, keys=to_list("Seed","Length")) seed_width = soyconf%parse_json(filename=config, keys=to_list("Seed","Width")) seed_thickness = soyconf%parse_json(filename=config, keys=to_list("Seed","Thickness")) seed_division = soyconf%parse_json(filename=config, keys=to_list("Seed","Division")) call obj%init(& radius=[seed_length,seed_width,seed_thickness],& division=[seed_division,seed_division,seed_division]) return endif endif !if(.not.allocated(obj%InterNodeInfo) )then ! allocate(this%InterNodeInfo(0:obj%MaxBranchNum) ) ! ! default value ! do i=0,size(obj%InterNodeInfo) ! obj%InterNodeInfo(i)%FinalInterNodeLength = linspace([0.030d0,0.060d0],30) ! obj%InterNodeInfo(i)%FinalLeafLength = linspace([0.050d0,0.20d0],30) ! obj%InterNodeInfo(i)%FinalLeafWidth = linspace([0.020d0,0.25d0],30) ! obj%InterNodeInfo(i)%FinalPetioleLength = linspace([0.050d0,0.25d0],30) ! enddo !endif if (timeOpt) then call time%start() end if call obj%remove() ! set default parameters ! stem obj%br_node(:) = 0 obj%br_from(:) = 0 obj%br_length(:) = 0.0d0 obj%br_angle_ave(:) = 0.0d0 obj%br_angle_sig(:) = 10.0d0 !obj%br_angle_ave(1)=10.0d0 !obj%br_angle_sig(1)=2.0d0 obj%ms_angle_ave = 0.0d0 obj%ms_angle_sig = 2.0d0 ! for roots obj%brr_node(:) = 0 obj%brr_from(:) = 0 obj%brr_length(:) = 0.0d0 obj%brr_angle_ave(:) = 0.0d0 obj%brr_angle_sig(:) = 10.0d0 obj%brr_angle_ave(1) = 30.0d0 obj%brr_angle_sig(1) = 2.0d0 obj%mr_angle_ave = 0.0d0 obj%mr_angle_sig = 2.0d0 ! peti ! is also stem obj%peti_size_ave(:) = 0.20d0 obj%peti_size_sig(:) = 0.010d0 obj%peti_width_ave(:) = 0.0050d0 obj%peti_width_sig(:) = 0.00010d0 obj%peti_angle_ave(:) = 30.0d0 obj%peti_angle_sig(:) = 1.00d0 ! leaf obj%leaf_length_ave(:) = 0.20d0 obj%leaf_length_sig(:) = 0.01d0 obj%leaf_width_ave(:) = 0.050d0 obj%leaf_width_sig(:) = 0.010d0 obj%leaf_thickness_ave(:) = 0.00100d0 obj%leaf_thickness_sig(:) = 0.00050d0 obj%leaf_angle_ave(:) = 80.0d0 obj%leaf_angle_sig(:) = 10.0d0 if (timeOpt) then print *, "[1] set default values :: " call time%show() end if ! 子葉節、初生葉節、根の第1節まで種子の状態で存在 ! 節を生成するためのスクリプトを開く if (.not. present(config) .or. index(config, ".json") == 0) then ! デフォルトの設定を生成 print *, "New soybean-configuration >> soyconfig.json" call soyconf%open("soyconfig.json") write (soyconf%fh, *) '{' write (soyconf%fh, *) ' "type": "soybean",' write (soyconf%fh, *) ' "stage": 0,' write (soyconf%fh, *) ' "length": 0.0090,' write (soyconf%fh, *) ' "width" : 0.0081,' write (soyconf%fh, *) ' "height": 0.0072,' write (soyconf%fh, *) ' "MaxLeafNum": 50,' write (soyconf%fh, *) ' "MaxRootNum":200,' write (soyconf%fh, *) ' "MaxStemNum": 50,' ! stem write (soyconf%fh, *) ' "br_node" : 0,' write (soyconf%fh, *) ' "br_from" : 0,' write (soyconf%fh, *) ' "br_length" : 0.00,' write (soyconf%fh, *) ' "br_angle_ave" : 0.00,' write (soyconf%fh, *) ' "br_angle_sig" : 10.00,' write (soyconf%fh, *) ' "br_angle_ave(1)": 0.00,' write (soyconf%fh, *) ' "br_angle_sig(1)": 10.00,' write (soyconf%fh, *) ' "ms_angle_ave": 0.00,' write (soyconf%fh, *) ' "ms_angle_sig": 2.00,' ! root write (soyconf%fh, *) ' "brr_node" : 0,' write (soyconf%fh, *) ' "brr_from" : 0,' write (soyconf%fh, *) ' "brr_length" : 0.00,' write (soyconf%fh, *) ' "brr_angle_ave" : 0.00,' write (soyconf%fh, *) ' "brr_angle_sig" : 10.00,' write (soyconf%fh, *) ' "brr_angle_ave(1)": 360.00,' write (soyconf%fh, *) ' "brr_angle_sig(1)": 2.00,' write (soyconf%fh, *) ' "mr_angle_ave": 0.00,' write (soyconf%fh, *) ' "mr_angle_sig": 2.00,' ! peti ! is also stem write (soyconf%fh, *) ' "peti_size_ave" : 0.200,' write (soyconf%fh, *) ' "peti_size_sig" : 0.0100,' write (soyconf%fh, *) ' "peti_width_ave" : 0.00500,' write (soyconf%fh, *) ' "peti_width_sig" : 0.000100,' write (soyconf%fh, *) ' "peti_angle_ave" : 30.00,' write (soyconf%fh, *) ' "peti_angle_sig" : 1.000,' ! leaf write (soyconf%fh, *) ' "leaf_length_ave" : 0.200,' write (soyconf%fh, *) ' "leaf_length_sig" : 0.010,' write (soyconf%fh, *) ' "leaf_width_ave" : 0.0500,' write (soyconf%fh, *) ' "leaf_width_sig" : 0.0100,' write (soyconf%fh, *) ' "leaf_thickness_ave" : 0.001000,' write (soyconf%fh, *) ' "leaf_thickness_sig" : 0.000500,' write (soyconf%fh, *) ' "leaf_angle_ave" : 80.00,' write (soyconf%fh, *) ' "leaf_angle_sig" : 10.00' write (soyconf%fh, *) '}' conf = "soyconfig.json" call soyconf%close() else conf = config end if if (timeOpt) then print *, "[2] create default config " call time%show() end if line = soyconf%parse(conf, key1="Genotype", key2="Dt1") if (index(line, "Dt1") /= 0) then obj%determinate = .False. else obj%determinate = .True. end if call soyconf%open(conf) blcount = 0 do read (soyconf%fh, '(a)') line if (debug) print *, line if (adjustl(line) == "{") then blcount = 1 cycle end if if (adjustl(line) == "}") then exit end if if (blcount == 1) then if (index(line, "Name") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%name end if if (index(line, "Mainstem") /= 0) then do read (soyconf%fh, '(a)') line if (debug) print *, line if (index(line, "}") /= 0) then exit end if if (index(line, "Length") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%ms_length end if if (index(line, "Width") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%ms_width end if if (index(line, "Node") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%ms_node end if end do end if if (index(line, "Branch#") /= 0) then rmc = index(line, "{") if (rmc /= 0) then line(rmc:rmc) = " " end if rmc = index(line, '"') if (rmc /= 0) then line(rmc:rmc) = " " end if rmc = index(line, '"') if (rmc /= 0) then line(rmc:rmc) = " " end if rmc = index(line, ':') if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, "#") if (debug) print *, line read (line(id + 1:), *) branch_id do read (soyconf%fh, '(a)') line if (debug) print *, line if (index(line, "}") /= 0) then exit end if if (index(line, "Length") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%br_length(branch_id) end if if (index(line, "Width") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%br_Width(branch_id) end if if (index(line, "Node") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%br_node(branch_id) end if if (index(line, "From") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%br_from(branch_id) end if end do end if ! for roots if (index(line, "Mainroot") /= 0) then do read (soyconf%fh, '(a)') line if (debug) print *, line if (index(line, "}") /= 0) then exit end if if (index(line, "Length") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%mr_length end if if (index(line, "Width") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%mr_width end if if (index(line, "Node") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%mr_node end if end do end if if (index(line, "Branchroot#") /= 0) then rmc = index(line, "{") if (rmc /= 0) then line(rmc:rmc) = " " end if rmc = index(line, '"') if (rmc /= 0) then line(rmc:rmc) = " " end if rmc = index(line, '"') if (rmc /= 0) then line(rmc:rmc) = " " end if rmc = index(line, ':') if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, "#") if (debug) print *, line read (line(id + 1:), *) branch_id do read (soyconf%fh, '(a)') line if (debug) print *, line if (index(line, "}") /= 0) then exit end if if (index(line, "Length") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%brr_length(branch_id) end if if (index(line, "Width") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%brr_Width(branch_id) end if if (index(line, "Node") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%brr_node(branch_id) end if if (index(line, "From") /= 0) then rmc = index(line, ",") if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%brr_from(branch_id) end if end do end if if (index(line, "rootconfig") /= 0) then ! 茎の設定ファイル rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%rootconfig end if if (index(line, "stemconfig") /= 0) then ! 茎の設定ファイル rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%stemconfig end if if (index(line, "leafconfig") /= 0) then ! 茎の設定ファイル rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%leafconfig end if if (index(line, "stage") /= 0) then ! 生育ステージ rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%stage_id end if if (index(line, "MaxLeafNum") /= 0) then ! 生育ステージ rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%MaxLeafNum end if if (index(line, "MaxStemNum") /= 0) then ! 生育ステージ rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%MaxStemNum end if if (index(line, "MaxRootNum") /= 0) then ! 生育ステージ rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%MaxRootNum end if if (index(line, "length") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%seed_length end if if (index(line, "width") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%seed_width end if if (index(line, "height") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) obj%seed_height end if ! for version 2020.11.24 ! stem if (index(line, "br_angle_ave") /= 0 .and. index(line, "br_angle_ave(") == 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%br_angle_ave(:) = readvalreal end if if (index(line, "br_angle_sig") /= 0 .and. index(line, "br_angle_sig(") == 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%br_angle_sig(:) = readvalreal end if if (index(line, "br_angle_ave(1)") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%br_angle_ave(1) = readvalreal end if if (index(line, "br_angle_sig(1)") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%br_angle_sig(1) = readvalreal end if if (index(line, "ms_angle_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%ms_angle_ave = readvalreal end if if (index(line, "ms_angle_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%ms_angle_sig = readvalreal end if ! peti ! is also stem if (index(line, "peti_size_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%peti_size_ave(:) = readvalreal end if if (index(line, "peti_size_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%peti_size_sig(:) = readvalreal end if if (index(line, "peti_width_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%peti_width_ave(:) = readvalreal end if if (index(line, "peti_width_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%peti_width_sig(:) = readvalreal end if if (index(line, "peti_angle_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%peti_angle_ave(:) = readvalreal end if if (index(line, "peti_angle_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%peti_angle_sig(:) = readvalreal end if ! leaf if (index(line, "leaf_length_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_length_ave(:) = readvalreal end if if (index(line, "leaf_length_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_length_sig(:) = readvalreal end if if (index(line, "leaf_width_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_width_ave(:) = readvalreal end if if (index(line, "leaf_width_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_width_sig(:) = readvalreal end if if (index(line, "leaf_thickness_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_thickness_ave(:) = readvalreal end if if (index(line, "leaf_thickness_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_thickness_sig(:) = readvalreal end if if (index(line, "leaf_angle_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_angle_ave(:) = readvalreal end if if (index(line, "leaf_angle_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%leaf_angle_sig(:) = readvalreal end if ! added in 2020/12/15 ! for roots if (index(line, "brr_angle_ave") /= 0 .and. index(line, "brr_angle_ave(") == 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%brr_angle_ave(:) = readvalreal end if if (index(line, "brr_angle_sig") /= 0 .and. index(line, "brr_angle_sig(") == 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%brr_angle_sig(:) = readvalreal end if if (index(line, "brr_angle_ave(1)") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%brr_angle_ave(1) = readvalreal end if if (index(line, "brr_angle_sig(1)") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%brr_angle_sig(1) = readvalreal end if if (index(line, "mr_angle_ave") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%mr_angle_ave = readvalreal end if if (index(line, "mr_angle_sig") /= 0) then rmc = index(line, ",") ! カンマがあれば除く if (rmc /= 0) then line(rmc:rmc) = " " end if id = index(line, ":") read (line(id + 1:), *) readvalreal obj%mr_angle_sig = readvalreal end if cycle end if end do call soyconf%close() if (index(config, ".json") == 0) then obj%stemconfig = " " obj%rootconfig = " " obj%leafconfig = " " end if if (timeOpt) then print *, "[3] read config " call time%show() end if if (obj%ms_node /= 0) then ! loaded from Mainstem-Branches relation file format ! ex. ! { ! "Name":"soybean", ! "Mainstem":{ ! "Length":1.2, ! "Node":13 ! }, ! "Branch#1":{ ! "From":1, ! "Length":0.6, ! "Node":7 ! }, ! "Branch#2":{ ! "From":3, ! "Length":0.2, ! "Node":2 ! }, ! "Branch#3":{ ! "From":4, ! "Length":0.2, ! "Node":2 ! } ! } ! count number of nodes !num_node = countif(obj%ms_node,notEquai=.true.,0) !num_node = num_node + countif(obj%br_node,notEquai=.true.,0) allocate (obj%leaf(obj%MaxLeafNum)) allocate (obj%root(obj%MaxrootNum)) allocate (obj%stem(obj%MaxstemNum)) allocate (obj%leafYoungModulus(obj%MaxLeafNum)) allocate (obj%rootYoungModulus(obj%MaxrootNum)) allocate (obj%stemYoungModulus(obj%MaxstemNum)) ! default value obj%leafYoungModulus(:) = 1000.0d0 obj%rootYoungModulus(:) = 1000.0d0 obj%stemYoungModulus(:) = 1000.0d0 allocate (obj%leafPoissonRatio(obj%MaxLeafNum)) allocate (obj%rootPoissonRatio(obj%MaxrootNum)) allocate (obj%stemPoissonRatio(obj%MaxstemNum)) obj%leafPoissonRatio(:) = 0.30d0 obj%rootPoissonRatio(:) = 0.30d0 obj%stemPoissonRatio(:) = 0.30d0 allocate (obj%leafDensity(obj%MaxLeafNum)) allocate (obj%rootDensity(obj%MaxrootNum)) allocate (obj%stemDensity(obj%MaxstemNum)) obj%leafDensity(:) = 0.0d0 obj%rootDensity(:) = 0.0d0 obj%stemDensity(:) = 0.0d0 allocate (obj%stem2stem(obj%MaxstemNum, obj%MaxstemNum)) allocate (obj%leaf2stem(obj%MaxstemNum, obj%MaxLeafNum)) allocate (obj%root2stem(obj%MaxrootNum, obj%MaxstemNum)) allocate (obj%root2root(obj%MaxrootNum, obj%MaxrootNum)) obj%stem2stem(:, :) = 0 obj%leaf2stem(:, :) = 0 obj%root2stem(:, :) = 0 obj%root2root(:, :) = 0 ! set mainstem allocate (obj%NodeID_MainStem(obj%ms_node)) if (index(obj%stemconfig, ".json") == 0) then call stem%init( & x_num=obj%stem_division(1), & y_num=obj%stem_division(2), & z_num=obj%stem_division(3) & ) else call stem%init(config=obj%stemconfig) end if do i = 1, obj%ms_node !call obj%stem(i)%init(config=obj%stemconfig) obj%stem(i) = stem obj%stem(i)%stemID = 0 obj%stem(i)%InterNodeID = i obj%stem(i)%already_grown = .true. obj%NodeID_MainStem(i) = i call obj%stem(i)%resize( & x=obj%ms_width, & y=obj%ms_width, & z=obj%ms_length/dble(obj%ms_node) & ) call obj%stem(i)%move( & x=-obj%ms_width/2.0d0, & y=-obj%ms_width/2.0d0, & z=-obj%ms_length/dble(obj%ms_node)/2.0d0 & ) call obj%stem(i)%rotate( & x=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)), & y=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)), & z=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)) & ) end do if (timeOpt) then print *, "[4] created Main stem." call time%show() end if do i = 1, obj%ms_node - 1 call obj%stem(i + 1)%connect("=>", obj%stem(i)) obj%stem2stem(i + 1, i) = 1 end do ! set branches k = obj%ms_node allocate (obj%NodeID_Branch(size(obj%br_node))) do i = 1, size(obj%br_node) ! num branch allocate (obj%NodeID_Branch(i)%ID(obj%br_node(i))) do j = 1, obj%br_node(i) k = k + 1 !call obj%stem(k)%init(config=obj%stemconfig) obj%stem(k) = stem obj%stem(k)%stemID = i obj%stem(k)%InterNodeID = j obj%stem(k)%already_grown = .true. obj%NodeID_Branch(i)%ID(j) = k call obj%stem(k)%resize( & x=obj%br_width(i), & y=obj%br_width(i), & z=obj%br_length(i)/dble(obj%br_node(i)) & ) call obj%stem(k)%move( & x=-obj%br_width(i)/2.0d0, & y=-obj%br_width(i)/2.0d0, & z=-obj%br_length(i)/dble(obj%br_node(i))/2.0d0 & ) call obj%stem(k)%rotate( & x=radian(random%gauss(mu=obj%br_angle_ave(j), sigma=obj%br_angle_sig(j))), & y=0.0d0, & z=radian(360.0d0*random%random()) & ) if (j == 1) then call obj%stem(k)%connect("=>", obj%stem(obj%br_from(i))) obj%stem2stem(k, obj%br_from(i)) = 1 else call obj%stem(k)%connect("=>", obj%stem(k - 1)) obj%stem2stem(k, k - 1) = 1 end if end do end do if (timeOpt) then print *, "[4] created Branches." call time%show() end if ! peti and leaf obj%num_stem_node = k obj%num_leaf = 0 ! bugfix 2021/08/18 !call leaf%init(config=obj%leafconfig,species=PF_GLYCINE_SOJA) if (index(obj%leafconfig, ".json") == 0) then call leaf%init(species=PF_GLYCINE_SOJA, & x_num=obj%leaf_division(1), & y_num=obj%leaf_division(2), & z_num=obj%leaf_division(3) & ) else call leaf%init(config=obj%leafconfig, species=PF_GLYCINE_SOJA) end if if (.not. stem%empty()) then call stem%remove() end if if (index(obj%stemconfig, ".json") == 0) then call stem%init( & x_num=obj%peti_division(1), & y_num=obj%peti_division(2), & z_num=obj%peti_division(3) & ) else call stem%init(config=obj%stemconfig) end if do i = 1, k ! ３複葉 ! add peti obj%num_stem_node = obj%num_stem_node + 1 !call obj%stem(obj%num_stem_node)%init(config=obj%stemconfig) obj%stem(obj%num_stem_node) = stem obj%stem(obj%num_stem_node)%already_grown = .true. call obj%stem(obj%num_stem_node)%resize( & x=random%gauss(mu=obj%peti_width_ave(i), sigma=obj%peti_width_sig(i)), & y=random%gauss(mu=obj%peti_width_ave(i), sigma=obj%peti_width_sig(i)), & z=random%gauss(mu=obj%peti_size_ave(i), sigma=obj%peti_size_sig(i)) & ) call obj%stem(obj%num_stem_node)%rotate( & x=radian(random%gauss(mu=obj%peti_angle_ave(i), sigma=obj%peti_angle_sig(i))), & y=0.0d0, & z=radian(360.0d0*random%random()) & ) call obj%stem(obj%num_stem_node)%connect("=>", obj%stem(i)) !obj%leaf2stem(num_stem_node,i) = 1 obj%stem2stem(obj%num_stem_node, i) = 1 ! add leaves leaf_z_angles = linspace([0.0d0, 360.0d0], obj%max_num_leaf_per_petiole + 1) do j = 1, obj%max_num_leaf_per_petiole leaf_z_angles(j) = radian(leaf_z_angles(j)) end do leaf_z_angles(:) = leaf_z_angles(:) + radian(random%random()*360.0d0) do j = 1, obj%max_num_leaf_per_petiole obj%num_leaf = obj%num_leaf + 1 !call obj%leaf(obj%num_leaf)%init(config=obj%leafconfig,species=PF_GLYCINE_SOJA) obj%leaf(obj%num_leaf) = leaf obj%leaf(obj%num_leaf)%LeafID = j y_val = random%gauss(mu=obj%leaf_thickness_ave(i), sigma=obj%leaf_thickness_sig(i)) z_val = random%gauss(mu=obj%leaf_length_ave(i), sigma=obj%leaf_length_sig(i)) x_val = random%gauss(mu=obj%leaf_width_ave(i), sigma=obj%leaf_width_sig(i)) obj%leaf(obj%num_leaf)%already_grown = .true. call obj%leaf(obj%num_leaf)%resize( & y=y_val, & z=z_val, & x=x_val & ) call obj%leaf(obj%num_leaf)%move( & y=-y_val/2.0d0, & z=-z_val/2.0d0, & x=-x_val/2.0d0 & ) call obj%leaf(obj%num_leaf)%rotate( & x=radian(random%gauss(mu=obj%leaf_angle_ave(i), sigma=obj%leaf_angle_sig(i))), & y=0.0d0, & z=leaf_z_angles(j) & ) call obj%leaf(obj%num_leaf)%connect("=>", obj%stem(obj%num_stem_node)) obj%leaf2stem(obj%num_leaf, obj%num_stem_node) = 1 end do end do if (timeOpt) then print *, "[4] created Peti and Leaves." call time%show() end if ! set mainroot !call root%init(obj%rootconfig) if (index(obj%rootconfig, ".json") == 0) then call root%init( & x_num=obj%root_division(1), & y_num=obj%root_division(2), & z_num=obj%root_division(3) & ) else call root%init(config=obj%rootconfig) end if do i = 1, obj%mr_node obj%root(i) = root obj%root(i)%already_grown = .true. call obj%root(i)%resize( & x=obj%mr_width, & y=obj%mr_width, & z=obj%mr_length/dble(obj%mr_node) & ) call obj%root(i)%move( & x=-obj%mr_width/2.0d0, & y=-obj%mr_width/2.0d0, & z=-obj%mr_length/dble(obj%mr_node)/2.0d0 & ) call obj%root(i)%rotate( & x=radian(random%gauss(mu=obj%mr_angle_ave, sigma=obj%mr_angle_sig)), & y=radian(random%gauss(mu=obj%mr_angle_ave, sigma=obj%mr_angle_sig)), & z=radian(random%gauss(mu=obj%mr_angle_ave, sigma=obj%mr_angle_sig)) & ) end do do i = 1, obj%mr_node - 1 if (i == 1) then call obj%root(1)%connect("=>", obj%stem(1)) obj%root2stem(1, 1) = 1 end if call obj%root(i + 1)%connect("=>", obj%root(i)) obj%root2root(i + 1, i) = 1 end do ! set branches k = obj%mr_node do i = 1, size(obj%brr_node) do j = 1, obj%brr_node(i) k = k + 1 !call obj%root(k)%init(config=obj%rootconfig) obj%root(k) = root obj%root(k)%already_grown = .true. call obj%root(k)%resize( & x=obj%mr_width, & y=obj%mr_width, & z=obj%mr_length/dble(obj%mr_node) & ) call obj%root(k)%move( & x=-obj%mr_width/2.0d0, & y=-obj%mr_width/2.0d0, & z=-obj%mr_length/dble(obj%mr_node)/2.0d0 & ) call obj%root(k)%rotate( & x=radian(random%gauss(mu=obj%brr_angle_ave(j), sigma=obj%brr_angle_sig(j))), & y=0.0d0, & z=radian(360.0d0*random%random()) & ) if (j == 1) then call obj%root(k)%connect("=>", obj%root(obj%brr_from(i))) obj%root2root(k, obj%brr_from(i)) = 1 else call obj%root(k)%connect("=>", obj%root(k - 1)) obj%root2root(k, k - 1) = 1 end if end do end do obj%stage = "V"//str(obj%ms_node) call obj%update() call obj%fixReversedElements() if (timeOpt) then print *, "[4] create objects." call time%show() end if return else ! create leaf, root, stem allocate (obj%leaf(obj%MaxLeafNum)) allocate (obj%root(obj%MaxrootNum)) allocate (obj%stem(obj%MaxstemNum)) allocate (obj%leafYoungModulus(obj%MaxLeafNum)) allocate (obj%rootYoungModulus(obj%MaxrootNum)) allocate (obj%stemYoungModulus(obj%MaxstemNum)) ! default value obj%leafYoungModulus(:) = 1000.0d0 obj%rootYoungModulus(:) = 1000.0d0 obj%stemYoungModulus(:) = 1000.0d0 allocate (obj%leafPoissonRatio(obj%MaxLeafNum)) allocate (obj%rootPoissonRatio(obj%MaxrootNum)) allocate (obj%stemPoissonRatio(obj%MaxstemNum)) obj%leafPoissonRatio(:) = 0.30d0 obj%rootPoissonRatio(:) = 0.30d0 obj%stemPoissonRatio(:) = 0.30d0 allocate (obj%leafDensity(obj%MaxLeafNum)) allocate (obj%rootDensity(obj%MaxrootNum)) allocate (obj%stemDensity(obj%MaxstemNum)) obj%leafDensity(:) = 0.0d0 obj%rootDensity(:) = 0.0d0 obj%stemDensity(:) = 0.0d0 allocate (obj%stem2stem(obj%MaxstemNum, obj%MaxstemNum)) allocate (obj%leaf2stem(obj%MaxstemNum, obj%MaxLeafNum)) allocate (obj%root2stem(obj%MaxrootNum, obj%MaxstemNum)) allocate (obj%root2root(obj%MaxrootNum, obj%MaxrootNum)) !allocate(obj%struct%NodCoord(4,3) ) !allocate(obj%struct%ElemNod(3,2) ) !allocate(obj%struct%ElemMat(3) ) ! 子葉結節部=(0,0,0) !obj%struct%NodCoord(1,1:3) = 0.0d0 call obj%leaf(1)%init(obj%leafconfig, species=PF_GLYCINE_SOJA) call obj%leaf(1)%rotate(x=radian(90.0d0), y=radian(90.0d0), z=radian(10.0d0)) obj%leaf(1)%already_grown = .true. call obj%leaf(2)%init(obj%leafconfig, species=PF_GLYCINE_SOJA) call obj%leaf(2)%rotate(x=radian(90.0d0), y=radian(90.0d0), z=radian(-10.0d0)) obj%leaf(2)%already_grown = .true. call obj%stem(1)%init(obj%stemconfig) call obj%stem(1)%rotate(x=radian(40.0d0)) obj%stem(1)%already_grown = .true. call obj%stem(2)%init(obj%stemconfig) call obj%stem(2)%rotate(x=radian(80.0d0)) obj%stem(2)%already_grown = .true. call obj%root(1)%init(obj%rootconfig) call obj%root(1)%fix(x=0.0d0, y=0.0d0, z=0.0d0) call obj%root(1)%rotate(x=radian(-60.0d0)) obj%root(1)%already_grown = .true. call obj%leaf(1)%connect("=>", obj%stem(1)) obj%leaf2stem(1, 1) = 1 call obj%leaf(2)%connect("=>", obj%stem(1)) obj%leaf2stem(2, 1) = 1 call obj%stem(2)%connect("=>", obj%stem(1)) obj%stem2stem(2, 1) = 1 call obj%root(1)%connect("=>", obj%stem(1)) obj%root2stem(1, 1) = 1 obj%stage = "VE" ! 初生葉結節部 !obj%struct%NodCoord(2,1) = 0.0d0 !obj%struct%NodCoord(2,2) = 0.0d0 !obj%struct%NodCoord(2,3) = 1.0d0/20.0d0*obj%seed_height ! 地際部 !obj%struct%NodCoord(3,1) = 1.0d0/4.0d0*obj%seed_length !obj%struct%NodCoord(3,2) = 0.0d0 !obj%struct%NodCoord(3,3) = -1.0d0/3.0d0*obj%seed_height ! 根冠 !obj%struct%NodCoord(4,1) = 1.0d0/2.0d0*obj%seed_length !obj%struct%NodCoord(4,2) = 0.0d0 !obj%struct%NodCoord(4,3) = -1.0d0/2.0d0*obj%seed_height ! 子葉-初生葉節 !obj%struct%ElemNod(1,1) = 1 !obj%struct%ElemNod(1,2) = 2 ! 地際-子葉節 !obj%struct%ElemNod(2,1) = 3 !obj%struct%ElemNod(2,2) = 1 ! 地際-根冠節 !obj%struct%ElemNod(3,1) = 3 !obj%struct%ElemNod(3,2) = 4 ! 子葉-初生葉節 stem: 1 !obj%struct%ElemMat(1) = 1 ! 地際-子葉節 stem: 1 !obj%struct%ElemMat(2) = 1 ! 地際-根冠節 primary root: -1 !obj%struct%ElemMat(3) = -1 ! FEメッシュを生成 ! 領域を確保 ! n = input(default=80,option=max_leaf_num) ! allocate(obj%leaf_list(n) ) ! n = input(default=80,option=max_stem_num) ! allocate(obj%stem_list(n) ) ! n = input(default=80,option=max_root_num) ! allocate(obj%root_list(n) ) ! ! ! 子葉のメッシュを生成 ! call obj%leaf_list(1)%create(meshtype="Sphere3D",x_num=10,y_num=10,z_num=10,& ! x_len=obj%seed_length,y_len=obj%seed_width,z_len=obj%seed_height) ! call obj%leaf_list(1)%move(x=0.0d0,y=-0.50d0*obj%seed_width,z=-0.50d0*obj%seed_height) ! ! call obj%leaf_list(2)%create(meshtype="Sphere3D",x_num=10,y_num=10,z_num=10,& ! x_len=obj%seed_length,y_len=obj%seed_width,z_len=obj%seed_height) ! call obj%leaf_list(2)%rotate(x=radian(180.0d0) ) ! call obj%leaf_list(2)%move(x=0.0d0,y=-0.50d0*obj%seed_width,z=-0.50d0*obj%seed_height) ! ! ! ! ! 子葉-初生葉節のメッシュを生成 ! rot(:) = 0.0d0 ! call obj%stem_list(1)%create(meshtype="rectangular3D",x_num=5,y_num=5,z_num=10,& ! x_len=obj%seed_width/6.0d0,y_len=obj%seed_width/6.0d0,z_len=obj%seed_length/4.0d0) ! ! 節基部の節点ID ! node_id = obj%struct%ElemNod(1,1) ! ! 節先端部の節点ID ! node_id2= obj%struct%ElemNod(1,2) ! ! 節基部の位置ベクトル ! loc(:) = obj%struct%NodCoord( node_id ,:) ! ! 節先端部までの方向ベクトル ! vec(:) = obj%struct%NodCoord( node_id2 ,:) - obj%struct%NodCoord( node_id ,:) ! ! ! structの構造データにメッシュデータを合わせる。 ! print *, obj%stem_list(1)%Mesh%BottomElemID ! print *, obj%stem_list(1)%Mesh%TopElemID ! ! elemid = obj%stem_list(1)%Mesh%BottomElemID ! node_id = obj%stem_list(1)%Mesh%ElemNod(elemID,1) ! meshloc(:) = obj%stem_list(1)%Mesh%NodCoord(node_id,:) ! ! elemid = obj%stem_list(1)%Mesh%TopElemID ! node_id = obj%stem_list(1)%Mesh%ElemNod(elemID,1) ! meshvec(:) = obj%stem_list(1)%Mesh%NodCoord(node_id,:)-meshloc(:) !print *, "loc",loc !print *, "meshloc",meshloc !print *, "vec",vec !print *, "meshvec",meshvec ! ! 節中央を原点へ ! call obj%stem_list(1)%move(x=-obj%seed_width/12.0d0,y=-obj%seed_width/12.0d0) ! ! print *, "loc",loc ! print *, "vec",vec ! print *, "rot",rot ! zaxis(:)=0.0d0 ! zaxis(3)=obj%seed_length/5.0d0 ! rot(:) = angles(zaxis,vec) ! call obj%stem_list(1)%move(x=loc(1),y=loc(2),z=loc(3) ) ! call obj%stem_list(1)%rotate(x=0.0d0,y=0.0d0,z=0.0d0 ) !! ! !! ! ! ! ! 地際-子葉節のメッシュを生成 ! rot(:) = 0.0d0 ! call obj%stem_list(2)%create(meshtype="rectangular3D",x_num=5,y_num=5,z_num=10,& ! x_len=obj%seed_width/6.0d0,y_len=obj%seed_width/6.0d0,z_len=obj%seed_length/4.0d0) ! ! 節基部の節点ID ! node_id = obj%struct%ElemNod(2,1) ! ! 節先端部の節点ID ! node_id2= obj%struct%ElemNod(2,2) ! ! 節基部の位置ベクトル ! loc(:) = obj%struct%NodCoord( node_id ,:) ! ! 節先端部までの方向ベクトル ! vec(:) = obj%struct%NodCoord( node_id2 ,:) - obj%struct%NodCoord( node_id ,:) ! ! 節中央を原点へ ! call obj%stem_list(2)%move(x=-obj%seed_width/12.0d0,y=-obj%seed_width/12.0d0,& ! z=-obj%seed_length/8.0d0) ! zaxis(:)=0.0d0 ! zaxis(3)=obj%seed_length/5.0d0 ! rot(:) = angles(zaxis,vec) ! print *, "loc",loc ! print *, "vec",vec ! print *, "rot",rot ! !call obj%stem_list(2)%rotate(x=rot(1),y=rot(2),z=rot(3) ) ! call obj%stem_list(2)%move(x=loc(1),y=loc(2),z=loc(3) ) ! ! ! ! ! 地際-根冠節のメッシュ生成 ! rot(:) = 0.0d0 ! call obj%root_list(1)%create(meshtype="rectangular3D",x_num=5,y_num=5,z_num=10,& ! x_len=obj%seed_width/6.0d0,y_len=obj%seed_width/6.0d0,z_len=obj%seed_length/4.0d0) ! ! 節基部の節点ID ! node_id = obj%struct%ElemNod(3,1) ! ! 節先端部の節点ID ! node_id2= obj%struct%ElemNod(3,2) ! ! 節基部の位置ベクトル ! loc(:) = obj%struct%NodCoord( node_id ,:) ! ! 節先端部までの方向ベクトル ! vec(:) = obj%struct%NodCoord( node_id2 ,:) - obj%struct%NodCoord( node_id ,:) ! ! 節基部へ移動 ! call obj%root_list(1)%move(x=-obj%seed_width/12.0d0,y=-obj%seed_width/12.0d0,& ! z=-obj%seed_length/8.0d0) ! call obj%root_list(1)%move(x=loc(1),y=loc(2),z=loc(3) ) ! zaxis(:)=0.0d0 ! zaxis(3)=obj%seed_length/5.0d0 ! rot(:) = angles(zaxis,vec) ! !call obj%root_list(1)%rotate(x=rot(1),y=rot(2),z=rot(3) ) ! print *, "loc",loc ! print *, "vec",vec ! print *, "rot",rot call obj%update() call obj%fixReversedElements() end if ! ここからレガシーモード if (present(regacy)) then if (regacy .eqv. .true.) then obj%Stage = "VE" if (present(FileName)) then fn = FileName else fn = "untitled" end if loc(:) = 0.0d0 if (present(x)) then loc(1) = x end if if (present(y)) then loc(2) = y end if if (present(z)) then loc(3) = z end if if (present(location)) then loc(:) = location(:) end if ! initialize RootSystem and NodeSystem if (.not. allocated(obj%RootSystem)) then allocate (obj%RootSystem(input(default=1000, option=max_PlantNode_num))) obj%num_of_root = 1 end if if (.not. allocated(obj%NodeSystem)) then allocate (obj%NodeSystem(input(default=1000, option=max_PlantNode_num))) obj%num_of_node = 1 end if ! setup seed if (Variety == "Tachinagaha" .or. Variety == "tachinagaha") then call obj%Seed%init(mass=mass, width1=9.70d0, width2=8.20d0, & width3=7.70d0, & water_content=water_content, radius=radius, location=loc) call obj%Seed%createMesh(FileName=fn//".stl", & ElemType="Tetrahedra") call obj%Seed%convertMeshType(Option="TetraToHexa") else print *, "Variety name :: is not implemented." stop end if ! setup primary node (plumule) call obj%NodeSystem(1)%init(Stage=obj%Stage, & Plantname="soybean", location=loc) ! setup primary node (radicle)) MaxThickness = input(default=0.20d0, & option=PlantRoot_diameter_per_seed_radius)*obj%Seed%radius Maxwidth = input(default=0.20d0, & option=PlantRoot_diameter_per_seed_radius)*obj%Seed%radius call obj%RootSystem(1)%init(Plantname="soybean", & Stage=obj%Stage, MaxThickness=MaxThickness, Maxwidth=Maxwidth, location=loc) obj%time = 0.0d0 call obj%update() call obj%fixReversedElements() return end if end if end subroutine ! ######################################## ! ######################################## subroutine growSoybean(obj, dt, light, air, temp, simple, add_apical) class(Soybean_), intent(inout) :: obj type(Light_), optional, intent(inout) :: light type(air_), optional, intent(in) :: air real(real64), optional, intent(in) :: temp real(real64), intent(in) :: dt! time-interval real(real64) :: ac_temp ! time-interval logical, optional, intent(in) :: add_apical integer(int32) :: i, j logical, optional, intent(in) :: simple integer(int32), allocatable :: apicals(:) integer(int32), allocatable :: last_apicals(:) integer(int32), allocatable :: last_last_apicals(:) integer(int32), allocatable :: has_branch(:) integer(int32) :: StemID, InterNodeID, PetioleID, LeafID, N_StemID logical :: add_node = .false. real(real64) :: count_dist obj%dt = dt call obj%update() if (present(simple)) then if (simple) then ! simple algorithmic growth ! growth by temp by time do i = 1, size(obj%stem) call obj%stem(i)%change_length_or_width(dt=dt) end do call obj%update() do i = 1, size(obj%leaf) call obj%leaf(i)%change_length_or_width(dt=dt) end do call obj%update() if (present(add_apical)) then if (add_apical) then apicals = obj%findApical() do i = 1, size(apicals) ! add stem&leaf if (i == 1) then ! main stem StemID = apicals(i) add_node = .false. j = size(obj%NodeID_MainStem) if (j >= 1) then N_StemID = obj%NodeID_MainStem(j) if (N_StemID >= 1) then if (obj%stem(N_StemID)%FullyExpanded(threshold=obj%FullyExpanded_stem_threshold)) then add_node = .true. end if end if end if else ! branch to StemID = apicals(i) add_node = .false. N_StemID = maxval(obj%NodeID_Branch(i - 1)%ID) ! 1個前の節ID if (obj%stem(N_StemID)%FullyExpanded(threshold=obj%FullyExpanded_stem_threshold)) then add_node = .true. end if end if if (add_node) then call obj%addNode(StemNodeID=apicals(i), mainstem_to_branch=.false.) end if call obj%update() end do ! branch has_branch = zeros(size(obj%NodeID_MainStem)) if (allocated(obj%MainStem_num_branch)) then has_branch(1:size(obj%MainStem_num_branch)) = obj%MainStem_num_branch(:) end if obj%MainStem_num_branch = has_branch ! we introduced an apploximation of the apical dominance. do i = 1, size(obj%NodeID_MainStem) - 1 if (obj%MainStem_num_branch(i) >= 1) then cycle else count_dist = 0.0d0 do j = i + 1, size(obj%NodeID_MainStem) count_dist = count_dist + obj%stem(obj%NodeID_MainStem(j))%getLength() end do if (count_dist > obj%apical_dominance_distance) then ! add Node if (obj%stem(i)%StemID /= 0) cycle !debug call obj%addNode(StemNodeID=i, mainstem_to_branch=.true.) !has_branch(i) = has_branch(i) + 1 obj%MainStem_num_branch(i) = obj%MainStem_num_branch(i) + 1 call obj%update() end if end if end do end if end if ! if(present(add_apical) )then ! if(add_apical)then ! apicals = obj%findApical() ! do i=1,size(apicals)-1 ! ! add stem&leaf ! StemID = apicals(i+1) ! add_node = .false. ! ! do j=size(obj%NodeID_Branch(i)%ID)-4,size(obj%NodeID_Branch(i)%ID)-1 ! ! if(j < 0 )then ! cycle ! else ! N_StemID = obj%NodeID_Branch(i)%ID(j) ! LeafID = obj%searchLeaf(StemID=i,InterNodeID=j,PetioleID=1,LeafID=1) ! ! if(LeafID < 1)then ! cycle ! endif ! ! if( obj%leaf(LeafID)%FullyExpanded(threshold=0.90d0 ))then ! ! add_node = .true. ! exit ! endif ! ! endif ! enddo ! if(add_node)then ! call obj%addNode(StemNodeID=apicals(i)) ! endif ! enddo ! endif ! endif call obj%update() return end if end if ! 光量子量を計算 call obj%laytracing(light=light) ! 光合成量を計算 do i = 1, size(obj%Leaf) if (obj%Leaf(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%leaf(i)%photosynthesis(dt=dt, air=air) end if end do ! シンクソース輸送を計算 !call obj%SinkSourceFlow() ! ソースの消耗、拡散を計算 !call obj%source2sink() ! 伸長を計算 !call obj%extention() ! 分化を計算、構造の更新 !call obj%development() !限界日長以下>> 花成 & 子実成長 !if( obj%DayLengthIsShort() .eqv. .true. )then !call soybean%updateFlowers() !call soybean%updatePods() !endif end subroutine ! ######################################## ! ######################################## subroutine SinkSourceFlowSoybean(obj, simple) class(Soybean_), intent(inout) :: obj logical, optional, intent(in) :: simple !type(DiffusionEq_) :: DiffusionEq if (present(simple)) then if (simple) then ! simple flow ! for each stem, return end if end if !call obj%lossEnergy() ! solve diffusion equation for multi-domains !call DiffusionEq%init(multiDomain=.true.,connectivity=obj%domainConnectivity) !call DiffusionEq%add(domainlist=obj%stem(:)%femdomain) !call DiffusionEq%add(domainlist=obj%leaf(:)%femdomain) !call DiffusionEq%add(domainlist=obj%root(:)%femdomain) !call DiffusionEq%FixValue(& !range=soil%femdonain, projection=true, values=soil%watercontent) !call DiffusionEq%run(dt=obj%dt) !soybean%sourceContent = Diffusion%unknowns end subroutine ! ######################################## ! ######################################## subroutine expanitionSoybean(obj) class(Soybean_), intent(inout) :: obj !type(ContactMechanics_) :: contact !contact%init(connectivity=obj%connectivity) !contact%add(domain=obj%stem(:)%domain) !contact%add(domain=obj%leaf(:)%domain) !contact%add(domain=obj%root(:)%domain) !contact%add(domain=soil) !contact%Density = obj%density() !contact%PoissonRatio = obj%PoissonRatio() !contact%PenaltyParameter = obj%PenaltyParameter() !contact%fix(bottom=.true., direction="xyz",displacement=[0.0d0,0.0d0,0.0d0] ) !contact%fix(side=.true., direction="xyz",displacement=[0.0d0,0.0d0,0.0d0] ) !contact%solve(dt=obj%dt) !soybean%CauchyStress = contact%CauchyStress !soybean%displacement = contact%displacement end subroutine ! ######################################## ! ######################################## subroutine developmentSoybean(obj) class(Soybean_), intent(inout) :: obj integer(int32) :: i, new_stem_id, new_leaf_id, new_root_id !do i=1, obj%numStemApical ! stemID=obj%StemApical(i) ! if(obj%stem(stemID)%source => obj%minimalSource )then ! new_stem_id = obj%newStem(from=StemID,how=obj%stem(stemID)%properties) ! new_leaf_id = obj%newLeaf(from=new_stem_id,how=obj%stem(stemID)%properties) ! endif !enddo !do i=1, obj%numleaf ! leafID=i ! call obj%leaf(leafID)%change_length_or_width() !enddo !do i=1, obj%numrootApical ! rootID=obj%rootApical(i) ! if(obj%root(rootID)%source => obj%minimalSource )then ! new_root_id = obj%newroot(from=rootID,how=obj%root(rootID)%properties) ! endif !enddo end subroutine ! ######################################## ! ######################################## subroutine updateFlowersSoybean(obj) class(Soybean_), intent(inout) :: obj integer(int32) :: i !do i=1, obj%numStem() ! call obj%stem(i)%updateFlowerCapacity() !enddo end subroutine ! ######################################## ! ######################################## subroutine updatePodsSoybean(obj) class(Soybean_), intent(inout) :: obj integer(int32) :: i !do i=1, obj%numStem() ! call obj%stem(i)%updatePodCapacity() ! call obj%stem(i)%growPod() !enddo end subroutine ! ######################################## ! ######################################## subroutine WaterAbsorptionSoybean(obj, temp, dt) class(Soybean_), intent(inout) :: obj real(real64), intent(in) :: temp, dt real(real64) :: a, b, c, d, AA, BB, w1max, w2max, w3max, time real(real64) :: x_rate, y_rate, z_rate, wx, wy, wz obj%time = obj%time + dt ! tested by tachinagaha, 2019 a = 0.00910d0 b = -1.76450d0 c = 3.32E-04 d = -0.0905180d0 AA = a*temp + b !BB=c*exp(d*temp) BB = c*temp + d ! width1 becomes 1.7 times, width2 becomes 1.2, width3 becomes 1.1 w1max = 1.70d0 w2max = 1.20d0 w3max = 1.10d0 obj%seed%width1 = obj%seed%width1_origin*(w1max - AA*exp(-BB*obj%time)) obj%seed%width2 = obj%seed%width2_origin*(w2max - AA*exp(-BB*obj%time)) obj%seed%width3 = obj%seed%width3_origin*(w3max - AA*exp(-BB*obj%time)) ! linear model; it should be changed in near future. if (obj%time > 60.0d0*6.0d0) then obj%seed%width2 = obj%seed%width2_origin*(w2max) obj%seed%width3 = obj%seed%width3_origin*(w3max) else obj%seed%width2 = obj%seed%width2_origin + obj%seed%width2_origin*(w2max - 1.0d0)*(obj%time)/(60.0d0*6.0d0) obj%seed%width3 = obj%seed%width3_origin + obj%seed%width3_origin*(w3max - 1.0d0)*(obj%time)/(60.0d0*6.0d0) end if wx = maxval(obj%Seed%FEMDomain%Mesh%NodCoord(:, 1)) - minval(obj%Seed%FEMDomain%Mesh%NodCoord(:, 1)) wy = maxval(obj%Seed%FEMDomain%Mesh%NodCoord(:, 2)) - minval(obj%Seed%FEMDomain%Mesh%NodCoord(:, 2)) wz = maxval(obj%Seed%FEMDomain%Mesh%NodCoord(:, 3)) - minval(obj%Seed%FEMDomain%Mesh%NodCoord(:, 3)) !print *, wx,wy,wz x_rate = 1.0d0/wx y_rate = 1.0d0/wy z_rate = 1.0d0/wz call obj%Seed%FEMDomain%resize(x_rate=x_rate, y_rate=y_rate, z_rate=z_rate) x_rate = obj%seed%width1 y_rate = obj%seed%width2 z_rate = obj%seed%width3 call obj%Seed%FEMDomain%resize(x_rate=x_rate, y_rate=y_rate, z_rate=z_rate) end subroutine ! ######################################## ! ######################################## subroutine exportSoybean(obj, FilePath, FileName, SeedID, withSTL, withMesh) class(Soybean_), intent(inout) :: obj character(*), optional, intent(in) :: FilePath character(*), intent(in) :: FileName integer(int32), optional, intent(inout) :: SeedID logical, optional, intent(in) :: withSTL, withMesh integer(int32) :: i, itr itr = SeedID ! if seed exists => output if (obj%Seed%num_of_seed >= 0) then if (present(withSTL)) then if (withSTL .eqv. .true.) then call obj%Seed%export(FileName=FileName, SeedID=itr, extention=".stl") end if end if if (present(withMesh)) then if (withMesh .eqv. .true.) then call obj%Seed%export(FileName=FileName, SeedID=itr, extention=".pos") end if end if if (present(FilePath)) then call obj%Seed%export(FileName=FilePath//"/seed.geo", SeedID=itr) else call obj%Seed%export(FileName=FileName, SeedID=itr) end if end if itr = itr + 1 ! export NodeSystem do i = 1, size(obj%NodeSystem) if (present(FilePath)) then call obj%NodeSystem(i)%export(FileName=FilePath//"/Node.geo", objID=itr) else call obj%NodeSystem(i)%export(FileName=FileName//"_Node.geo", objID=itr) end if if (i == obj%num_of_node) then exit end if end do ! export RootSystem do i = 1, size(obj%RootSystem) if (present(FilePath)) then call obj%RootSystem(i)%export(FileName=FilePath//"/Root.geo", RootID=itr) else call obj%RootSystem(i)%export(FileName=FileName//"_Root.geo", RootID=itr) end if if (i == obj%num_of_root) then exit end if end do SeedID = itr end subroutine ! ######################################## ! ######################################## ! ######################################## !subroutine initsoybean(obj,growth_habit,Max_Num_of_Node) ! class(soybean_) :: obj ! character(*),optional,intent(in) :: growth_habit ! integer(int32),optional,intent(in)::Max_Num_of_Node ! integer(int32) ::n ! ! if(present(growth_habit) )then ! obj%growth_habit=growth_habit ! else ! obj%growth_habit="determinate" ! endif ! ! obj%growth_stage="VE" ! ! n=input(default=100,option=Max_Num_of_Node) ! ! allocate(obj%NodeSystem(n)) ! obj%NumOfNode=0 ! obj%NumOfRoot=0 ! ! ! set an initial node and root ! ! two leaves, one root. ! ! call obj%AddNode() ! !end subroutine !! ######################################## ! ! ! ! ! ! !! ######################################## !subroutine AddNodeSoybean(obj,SizeRatio) ! class(soybean_),intent(inout)::obj ! real(real64),optional,intent(in)::SizeRatio ! real(real64) :: magnif ! ! magnif=input(default=1.0d0,option=SizeRatio) ! obj%NumOfNode=obj%NumOfNode+1 ! ! ! add leaves ! if(obj%NumOfNode==1 .or. obj%NumOfNode==2)then ! allocate(obj%NodeSystem(obj%NumOfNode)%leaf(2) ) ! call obj%NodeSystem(obj%NumOfNode)%leaf(1)%init(thickness=0.10d0*magnif,length=3.0d0*magnif,width=2.0d0*magnif) ! call obj%NodeSystem(obj%NumOfNode)%leaf(1)%init(thickness=0.10d0*magnif,length=3.0d0*magnif,width=2.0d0*magnif) ! else ! allocate(obj%NodeSystem(obj%NumOfNode)%leaf(3) ) ! call obj%NodeSystem(obj%NumOfNode)%leaf(1)%init(thickness=0.10d0*magnif,length=4.0d0*magnif,width=2.0d0*magnif) ! call obj%NodeSystem(obj%NumOfNode)%leaf(1)%init(thickness=0.10d0*magnif,length=4.0d0*magnif,width=2.0d0*magnif) ! call obj%NodeSystem(obj%NumOfNode)%leaf(1)%init(thickness=0.10d0*magnif,length=4.0d0*magnif,width=2.0d0*magnif) ! endif ! ! ! add stem ! if(obj%NumOfNode==1 .or. obj%NumOfNode==2)then ! allocate(obj%NodeSystem(obj%NumOfNode)%Stem(1) ) ! call obj%NodeSystem(obj%NumOfNode)%leaf(1)%init(thickness=0.10d0*magnif,length=3.0d0*magnif,width=2.0d0*magnif) ! endif ! ! ! add Peti ! if(obj%NumOfNode==1 .or. obj%NumOfNode==2)then ! allocate(obj%NodeSystem(obj%NumOfNode)%Peti(1) ) ! call obj%NodeSystem(obj%NumOfNode)%Peti(1)%init(thickness=0.10d0*magnif,length=3.0d0*magnif,width=2.0d0*magnif) ! endif ! !end subroutine !! ######################################## ! ! ######################################## subroutine showSoybean(obj, name) class(Soybean_), intent(inout) :: obj character(*), intent(in)::name if (obj%struct%empty() .eqv. .true.) then print *, "Error :: showSoybean>> no structure is imported." return end if call obj%struct%export(name=name) end subroutine ! ######################################## ! ######################################## function numleafsoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: ret, i ret = 0 if (.not. allocated(obj%leaf)) then return end if do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%Mesh%empty() .eqv. .false.) then ret = ret + 1 end if end do end function ! ######################################## ! ######################################## function numstemsoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: ret, i ret = 0 if (.not. allocated(obj%stem)) then return end if do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%Mesh%empty() .eqv. .false.) then ret = ret + 1 end if end do end function ! ######################################## ! ######################################## function numrootsoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: ret, i ret = 0 if (.not. allocated(obj%root)) then return end if do i = 1, size(obj%root) if (obj%root(i)%femdomain%Mesh%empty() .eqv. .false.) then ret = ret + 1 end if end do end function ! ######################################## ! ######################################## subroutine gmshSoybean(obj, name, num_threads, single_file) class(Soybean_), intent(inout) :: obj character(*), intent(in) :: name type(FEMDomain_) :: femdomain integer(int32), optional, intent(in) :: num_threads logical, optional, intent(in) :: single_file integer(int32) :: i, n if (present(single_file)) then if (single_file) then ! export mesh for a single file if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then femdomain = femdomain + obj%stem(i)%femdomain end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then femdomain = femdomain + obj%leaf(i)%femdomain end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%empty()) then femdomain = femdomain + obj%root(i)%femdomain end if end do end if call femdomain%gmsh(name=name) return end if end if n = input(default=1, option=num_threads) !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%stem) !if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%stem(i)%gmsh(name=name//"_stem"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%root) !if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%root(i)%gmsh(name=name//"_root"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%leaf) !if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%leaf(i)%gmsh(name=name//"_leaf"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel end subroutine ! ######################################## ! ######################################## subroutine mshSoybean(obj, name, num_threads) class(Soybean_), intent(inout) :: obj character(*), intent(in) :: name integer(int32), optional, intent(in) :: num_threads integer(int32) :: i, n type(IO_) :: f ! index file call f%open(name//"_index.txt", "w") if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then call f%write(name//"_stem"//str(i)//".msh") end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then call f%write(name//"_root"//str(i)//".msh") end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then call f%write(name//"_leaf"//str(i)//".msh") end if end do end if call f%close() n = input(default=1, option=num_threads) !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%stem) !if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%stem(i)%msh(name=name//"_stem"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%root) !if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%root(i)%msh(name=name//"_root"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%leaf) !if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%leaf(i)%msh(name=name//"_leaf"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel end subroutine ! ######################################## ! ######################################## subroutine vtkSoybean(obj, name, num_threads, single_file, & scalar_field, vector_field, tensor_field, field_name) class(Soybean_), intent(inout) :: obj character(*), intent(in) :: name character(*), optional, intent(in) :: field_name type(IO_) :: f type(FEMDomain_) :: femdomain integer(int32), optional, intent(in) :: num_threads real(real64), optional, intent(in) :: scalar_field(:) real(real64), optional, intent(in) :: vector_field(:, :) real(real64), optional, intent(in) :: tensor_field(:, :, :) integer(int32) :: i, n logical, optional, intent(in) :: single_file if (.not. allocated(obj%stem)) then if (.not. allocated(obj%leaf)) then if (.not. allocated(obj%root)) then return end if end if end if if (present(single_file)) then if (single_file) then ! export mesh for a single file if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then femdomain = femdomain + obj%stem(i)%femdomain end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then femdomain = femdomain + obj%leaf(i)%femdomain end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%empty()) then femdomain = femdomain + obj%root(i)%femdomain end if end do end if if (present(scalar_field)) then ! export scalar-valued field ! as a single file call femdomain%vtk(field=field_name, name=name, scalar=scalar_field) elseif (present(vector_field)) then ! export vector-valued field ! as a single file call femdomain%vtk(field=field_name, name=name, vector=vector_field) elseif (present(tensor_field)) then ! export tensor-valued field ! as a single file call femdomain%vtk(field=field_name, name=name, tensor=tensor_field) else call femdomain%vtk(field=field_name, name=name) end if return end if end if n = input(default=1, option=num_threads) ! index file call f%open(name//"_index.txt", "w") if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then call f%write(name//"_stem"//str(i)//".vtk") end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then call f%write(name//"_root"//str(i)//".vtk") end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then call f%write(name//"_leaf"//str(i)//".vtk") end if end do end if call f%close() if (allocated(obj%stem)) then !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%stem) !if(obj%stem(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%stem(i)%vtk(field_name=field_name, name=name//"_stem"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel end if if (allocated(obj%root)) then !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%root) !if(obj%root(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%root(i)%vtk(field_name=field_name, name=name//"_root"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel end if if (allocated(obj%leaf)) then !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%leaf) !if(obj%leaf(i)%femdomain%mesh%empty() .eqv. .false. )then call obj%leaf(i)%vtk(field_name=field_name, name=name//"_leaf"//str(i)) !endif end do !!$OMP end do !!$OMP end parallel end if end subroutine ! ######################################## ! ######################################## subroutine jsonSoybean(obj, name) class(Soybean_), intent(inout) :: obj character(*), intent(in) :: name integer(int32) :: i, countnum type(IO_) :: f call f%open(name//".json") call f%write("{") countnum = 0 do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty() .eqv. .false.) then countnum = countnum + 1 call f%write('"'//"stem"//str(i)//'":') call obj%stem(i)%femdomain%json(name=name//"_stem"//str(i), fh=f%fh, endl=.false.) end if end do call f%write('"num_stem":'//str(countnum)//',') countnum = 0 do i = 1, size(obj%root) if (obj%root(i)%femdomain%mesh%empty() .eqv. .false.) then countnum = countnum + 1 call f%write('"'//"root"//str(i)//'":') call obj%root(i)%femdomain%json(name=name//"_root"//str(i), fh=f%fh, endl=.false.) end if end do call f%write('"num_root":'//str(countnum)//',') countnum = 0 do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then countnum = countnum + 1 call f%write('"'//"leaf"//str(i)//'":') call obj%leaf(i)%femdomain%json(name=name//"_leaf"//str(i), fh=f%fh, endl=.false.) end if end do call f%write('"obj%num_leaf":'//str(countnum)//',') call f%write('"return_soybean":0') call f%write("}") call f%close() end subroutine ! ######################################## ! ######################################## subroutine stlSoybean(obj, name, num_threads, single_file) class(Soybean_), intent(inout) :: obj character(*), intent(in) :: name integer(int32), optional, intent(in) :: num_threads type(FEMDomain_) :: femdomain logical, optional, intent(in) :: single_file integer(int32) :: i, n type(IO_) :: f if (present(single_file)) then if (single_file) then ! export mesh for a single file if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then femdomain = femdomain + obj%stem(i)%femdomain end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then femdomain = femdomain + obj%leaf(i)%femdomain end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%empty()) then femdomain = femdomain + obj%root(i)%femdomain end if end do end if call femdomain%stl(name=name) return end if end if ! index file call f%open(name//"_index.txt", "w") if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then call f%write(name//"_stem"//str(i)//".stl") end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then call f%write(name//"_root"//str(i)//".stl") end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then call f%write(name//"_leaf"//str(i)//".stl") end if end do end if call f%close() n = input(default=1, option=num_threads) !call execute_command_line("echo ' ' > "//name//".stl") !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%stem(i)%stl(name=name//"_stem"//str(i)) !call execute_command_line("cat "//name//"_stem"//str(i)//"_000001.stl >> "//name//".stl") end if end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%root) if (obj%root(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%root(i)%stl(name=name//"_root"//str(i)) !call execute_command_line("cat "//name//"_root"//str(i)//"_000001.stl >> "//name//".stl") end if end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%leaf(i)%stl(name=name//"_leaf"//str(i)) !call execute_command_line("cat "//name//"_leaf"//str(i)//"_000001.stl >> "//name//".stl") end if end do !!$OMP end do !!$OMP end parallel call execute_command_line("cat "//name//"*_leaf*.stl > "//name//"_leaf.stl") call execute_command_line("cat "//name//"*_stem*.stl > "//name//"_stem.stl") call execute_command_line("cat "//name//"*_root*.stl > "//name//"_root.stl") call execute_command_line("cat "//name//"_leaf.stl "//name//"_stem.stl " & //name//"_root.stl > "//name//".stl") end subroutine ! ######################################## ! ######################################## subroutine plySoybean(obj, name, num_threads, single_file) class(Soybean_), intent(inout) :: obj character(*), intent(in) :: name integer(int32), optional, intent(in) :: num_threads type(FEMDomain_) :: femdomain logical, optional, intent(in) :: single_file integer(int32) :: i, n type(IO_) :: f if (present(single_file)) then if (single_file) then ! export mesh for a single file if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then femdomain = femdomain + obj%stem(i)%femdomain end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then femdomain = femdomain + obj%leaf(i)%femdomain end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%empty()) then femdomain = femdomain + obj%root(i)%femdomain end if end do end if call femdomain%ply(name=name) return end if end if ! index file call f%open(name//"_index.txt", "w") if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then call f%write(name//"_stem"//str(i)//".ply") end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then call f%write(name//"_root"//str(i)//".ply") end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then call f%write(name//"_leaf"//str(i)//".ply") end if end do end if call f%close() n = input(default=1, option=num_threads) !call execute_command_line("echo ' ' > "//name//".ply") !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%stem(i)%ply(name=name//"_stem"//str(i)) !call execute_command_line("cat "//name//"_stem"//str(i)//"_000001.ply >> "//name//".ply") end if end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%root) if (obj%root(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%root(i)%ply(name=name//"_root"//str(i)) !call execute_command_line("cat "//name//"_root"//str(i)//"_000001.ply >> "//name//".ply") end if end do !!$OMP end do !!$OMP end parallel !!$OMP parallel num_threads(n) private(i) !!$OMP do do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%leaf(i)%ply(name=name//"_leaf"//str(i)) !call execute_command_line("cat "//name//"_leaf"//str(i)//"_000001.ply >> "//name//".ply") end if end do !!$OMP end do !!$OMP end parallel call execute_command_line("cat "//name//"*_leaf*.ply > "//name//"_leaf.ply") call execute_command_line("cat "//name//"*_stem*.ply > "//name//"_stem.ply") call execute_command_line("cat "//name//"*_root*.ply > "//name//"_root.ply") call execute_command_line("cat "//name//"_leaf.ply "//name//"_stem.ply " & //name//"_root.ply > "//name//".ply") end subroutine ! ######################################## ! ######################################## subroutine moveSoybean(obj, x, y, z, reset) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: x, y, z logical,optional,intent(in) :: reset integer(int32) :: i if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%stem(i)%move(x=x, y=y, z=z, reset=reset) end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%leaf(i)%move(x=x, y=y, z=z, reset=reset) end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (obj%root(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%root(i)%move(x=x, y=y, z=z,reset=reset) end if end do end if end subroutine ! ######################################## ! ######################################## subroutine laytracingsoybean(obj, light, Transparency, Resolution) class(Soybean_), intent(inout) :: obj type(Light_), intent(in) :: light real(real64), optional, intent(in) :: Transparency, Resolution real(real64), allocatable :: ppfd(:) integer(int32), allocatable :: NumberOfElement(:) integer(int32) :: from, elem_id ! >>> regacy real(real64), allocatable :: stemcenter(:, :), stemradius(:) real(real64), allocatable :: leafcenter(:, :), leafradius(:) real(real64), allocatable :: elemnodcoord(:, :), x(:), x2(:) real(real64) :: max_PPFD, r, rc, r0 real(real64), parameter :: extinction_ratio = 100.0d0 ! ratio/m type(IO_) :: f integer(int32) :: i, j, n, num_particle, k, l, nodeid, m, totcount integer(int32) :: num_particle_leaf, tocount_leaf ! <<< regacy ppfd = obj%getPPFD(Light=Light, Transparency=Transparency, Resolution=Resolution) NumberOfElement = obj%getNumberOfElement() from = sum(NumberOfElement(1:obj%numstem())) elem_id = from do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then obj%leaf(i)%ppfd = zeros(obj%leaf(i)%femdomain%ne()) do j = 1, obj%leaf(i)%femdomain%ne() elem_id = elem_id + 1 obj%leaf(i)%ppfd(j) = ppfd(elem_id) end do end if end do return ! >>> Regacy ! 総当りで、総遮蔽長を割り出す ! 茎は光を通さない、葉は透過率あり、空間は透過率ゼロ ! 要素中心から頂点への平均長さを半径に持ち、要素中心を中心とする球 ! を考え、Layとの公差判定を行う。 num_particle = 0 do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then num_particle = num_particle + size(obj%leaf(i)%femdomain%mesh%ElemNod, 1) end if end do allocate (leafcenter(num_particle, 3), leafradius(num_particle)) leafcenter(:, :) = 0.0d0 leafradius(:) = 0.0d0 num_particle = 0 do i = 1, size(obj%leaf) if (obj%stem(i)%femdomain%mesh%empty() .eqv. .false.) then num_particle = num_particle + size(obj%stem(i)%femdomain%mesh%ElemNod, 1) end if end do allocate (stemcenter(num_particle, 3), stemradius(num_particle)) stemcenter(:, :) = 0.0d0 stemradius(:) = 0.0d0 num_particle = 0 do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then n = size(obj%leaf(i)%femdomain%mesh%Elemnod, 2) m = size(obj%leaf(i)%femdomain%mesh%Nodcoord, 2) allocate (elemnodcoord(n, m)) allocate (x(m)) do j = 1, size(obj%leaf(i)%femdomain%mesh%elemnod, 1) do k = 1, size(obj%leaf(i)%femdomain%mesh%elemnod, 2) nodeid = obj%leaf(i)%femdomain%mesh%elemnod(j, k) elemnodcoord(k, :) = obj%leaf(i)%femdomain%mesh%Nodcoord(nodeid, :) end do num_particle = num_particle + 1 do k = 1, size(elemnodcoord, 1) do l = 1, size(elemnodcoord, 2) leafcenter(num_particle, l) = & +leafcenter(num_particle, l) & + 1.0d0/dble(size(elemnodcoord, 1))*elemnodcoord(k, l) end do end do do k = 1, size(elemnodcoord, 1) x(:) = elemnodcoord(k, :) x(:) = x(:) - leafcenter(num_particle, :) if (k >= 2 .and. leafradius(num_particle) > sqrt(dot_product(x, x))) then leafradius(num_particle) = sqrt(dot_product(x, x)) elseif (k == 1) then leafradius(num_particle) = sqrt(dot_product(x, x)) else cycle end if end do end do deallocate (elemnodcoord) deallocate (x) end if end do num_particle = 0 do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty() .eqv. .false.) then n = size(obj%stem(i)%femdomain%mesh%Elemnod, 2) m = size(obj%stem(i)%femdomain%mesh%Nodcoord, 2) allocate (elemnodcoord(n, m)) allocate (x(m)) do j = 1, size(obj%stem(i)%femdomain%mesh%elemnod, 1) do k = 1, size(obj%stem(i)%femdomain%mesh%elemnod, 2) nodeid = obj%stem(i)%femdomain%mesh%elemnod(j, k) elemnodcoord(k, :) = obj%stem(i)%femdomain%mesh%Nodcoord(nodeid, :) end do num_particle = num_particle + 1 do k = 1, size(elemnodcoord, 1) do l = 1, size(elemnodcoord, 2) stemcenter(num_particle, l) = & +stemcenter(num_particle, l) & + 1.0d0/dble(size(elemnodcoord, 1))*elemnodcoord(k, l) end do end do do k = 1, size(elemnodcoord, 1) x(:) = elemnodcoord(k, :) x(:) = x(:) - stemcenter(num_particle, :) !最小半径で考える if (k >= 2 .and. stemradius(num_particle) > sqrt(dot_product(x, x))) then stemradius(num_particle) = sqrt(dot_product(x, x)) elseif (k == 1) then stemradius(num_particle) = sqrt(dot_product(x, x)) else cycle end if end do end do deallocate (elemnodcoord) deallocate (x) end if end do ! DEBUG call f%open("leaf.txt") do i = 1, size(leafcenter, 1) write (f%fh, *) leafcenter(i, :) end do call f%close() call f%open("stem.txt") do i = 1, size(stemcenter, 1) write (f%fh, *) stemcenter(i, :) end do call f%close() allocate (x(3), x2(3)) num_particle = 0 totcount = 0 tocount_leaf = 0 num_particle_leaf = 0 do i = 1, size(obj%leaf) !print *, i,"/",obj%numleaf() if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then ! 葉あり obj%leaf(i)%PPFD(:) = max_PPFD !!$OMP parallel do private(j) do j = 1, size(obj%leaf(i)%PPFD) totcount = tocount_leaf + j num_particle = num_particle_leaf + j ! それぞれの要素について、遮蔽particleを探索 ! 茎：全減衰 ! 葉：半減衰 ! 簡単のため上からのみ ! x-yのみについて見て、上方かつx-y平面距離が半径以内で覆陰判定 x(:) = leafcenter(num_particle, :) r0 = leafradius(num_particle) ! 枝による覆陰判定 do k = 1, size(stemcenter, 1) x2(:) = stemcenter(k, :) r = stemradius(k) rc = (x(1) - x2(1))**(2.0d0) + (x(2) - x2(2))**(2.0d0) rc = sqrt(rc) if (rc <= r0 + r .and. x(3) < x2(3)) then ! 茎により覆陰されてる obj%leaf(i)%PPFD(j) = 0.0d0 exit end if end do if (obj%leaf(i)%PPFD(j) == 0.0d0) then cycle end if do k = 1, size(leafcenter, 1) ! もし自信だったら除外 if (totcount == k) then cycle end if x2(:) = leafcenter(k, :) r = leafradius(k) rc = (x(1) - x2(1))**(2.0d0) + (x(2) - x2(2))**(2.0d0) rc = sqrt(rc) if (rc <= (r0 + r)/2.0d0 .and. x(3) < x2(3)) then ! 茎により覆陰されてる obj%leaf(i)%PPFD(j) = & obj%leaf(i)%PPFD(j)*(1.0d0 - extinction_ratio*2.0d0*r) if (obj%leaf(i)%PPFD(j) <= 0.0d0) then obj%leaf(i)%PPFD(j) = 0.0d0 end if end if end do end do !!$OMP end parallel do tocount_leaf = tocount_leaf + size(obj%leaf(i)%PPFD) num_particle_leaf = num_particle_leaf + size(obj%leaf(i)%PPFD) end if end do call f%open("PPFD.txt") do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty() .eqv. .false.) then ! 葉あり do j = 1, size(obj%leaf(i)%PPFD, 1) write (f%fh, *) obj%leaf(i)%PPFD(j), "leaf_id: ", str(i), "elem_id: ", str(j) end do end if end do call f%close() end subroutine ! ######################################## subroutine addNodeSoybean(obj, StemNodeID, RootNodeID, peti_width_ave, peti_width_sig, peti_size_ave & , peti_size_sig, peti_angle_ave, peti_angle_sig, leaf_thickness_ave, leaf_thickness_sig & , leaf_length_ave, leaf_length_sig, leaf_width_ave, leaf_width_sig, leaf_angle_sig & , leaf_angle_ave, mainstem_to_branch) class(Soybean_), intent(inout) :: obj integer(int32), optional, intent(in) :: StemNodeID, RootNodeID real(real64), optional, intent(in) :: peti_width_ave, peti_width_sig, peti_size_ave & , peti_size_sig, peti_angle_ave, peti_angle_sig, leaf_thickness_ave, leaf_thickness_sig & , leaf_length_ave, leaf_length_sig, leaf_width_ave, leaf_width_sig, leaf_angle_sig & , leaf_angle_ave logical, optional, intent(in) :: mainstem_to_branch logical :: mainstem_2_branch = .false. real(real64), allocatable :: leaf_z_angles(:) type(Random_) :: random type(soybean_NodeID_Branch_), allocatable :: old_NodeID_Branch(:) integer(int32) :: i, j, branch_id, My_StemID if (present(mainstem_to_branch)) then mainstem_2_branch = mainstem_to_branch end if call obj%update() if (present(StemNodeID)) then i = StemNodeID obj%leaf_thickness_ave(obj%num_leaf) = input( & default=obj%leaf_thickness_ave(obj%num_leaf), & option=leaf_thickness_ave) obj%leaf_thickness_sig(obj%num_leaf) = input( & default=obj%leaf_thickness_sig(obj%num_leaf), & option=leaf_thickness_sig) obj%leaf_length_ave(obj%num_leaf) = input( & default=obj%leaf_length_ave(obj%num_leaf), & option=leaf_length_ave) obj%leaf_length_sig(obj%num_leaf) = input( & default=obj%leaf_length_sig(obj%num_leaf), & option=leaf_length_sig) obj%leaf_width_ave(obj%num_leaf) = input( & default=obj%leaf_width_ave(obj%num_leaf), & option=leaf_width_ave) obj%leaf_width_sig(obj%num_leaf) = input( & default=obj%leaf_width_sig(obj%num_leaf), & option=leaf_width_sig) obj%leaf_angle_sig(obj%num_leaf) = input( & default=obj%leaf_angle_sig(obj%num_leaf), & option=leaf_angle_sig) obj%leaf_angle_ave(obj%num_leaf) = input( & default=obj%leaf_angle_ave(obj%num_leaf), & option=leaf_angle_ave) ! main stem -> main stem if (obj%isMainStem(StemNodeID) .and. .not. mainstem_2_branch) then print *, "Main -> Main", StemNodeID ! main stem i = StemNodeID call obj%stem(obj%numStem() + 1)%init(config=obj%stemconfig) call extend(obj%NodeID_MainStem) obj%NodeID_MainStem(size(obj%NodeID_MainStem)) = obj%numStem() if (obj%ms_node > 0.0d0) then call obj%stem(i)%resize( & x=obj%ms_width, & y=obj%ms_width, & z=obj%ms_length/dble(obj%ms_node) & ) end if call obj%stem(i)%rotate( & x=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)), & y=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)), & z=obj%stem(StemNodeID)%femdomain%total_rotation(3) + radian((random%random() - 0.50d0)*90.0d0) & ) call obj%stem(i)%change_length_or_width(dt=0.0d0) obj%stem(i)%StemID = 0 obj%stem(i)%InterNodeID = size(obj%NodeID_MainStem) ! branch -> branch elseif (.not. obj%isMainStem(StemNodeID) .and. .not. mainstem_2_branch) then i = StemNodeID branch_id = obj%BranchID(i) print *, "Branch -> Branch branch id", branch_id call obj%stem(obj%numStem() + 1)%init(config=obj%stemconfig) if (.not. allocated(obj%NodeID_Branch(branch_id)%ID)) then obj%NodeID_Branch(branch_id)%ID = [obj%numStem()] else obj%NodeID_Branch(branch_id)%ID = obj%NodeID_Branch(branch_id)%ID//[obj%numStem()] end if My_StemID = obj%numStem() call obj%stem(My_StemID)%rotate( & x=radian(random%gauss(mu=obj%br_angle_ave(branch_id), sigma=obj%br_angle_sig(branch_id))), & y=radian(random%gauss(mu=obj%br_angle_ave(branch_id), sigma=obj%br_angle_sig(branch_id))), & z=obj%stem(StemNodeID)%femdomain%total_rotation(3) + radian((random%random() - 0.50d0)*90.0d0) & ) call obj%stem(My_StemID)%change_length_or_width(dt=0.0d0) obj%stem(My_StemID)%StemID = branch_id obj%stem(My_StemID)%InterNodeID = size(obj%NodeID_Branch(branch_id)%ID) ! main stem -> branch elseif (obj%isMainStem(StemNodeID) .and. mainstem_2_branch) then ! branch i = StemNodeID ! 1 : stem ID of main stem My_StemID = i ! create new internode call obj%stem(obj%numStem() + 1)%init(config=obj%stemconfig) ! if mainstem -> branch if (allocated(obj%MainStem_num_branch)) then branch_id = 1 do j = 1, size(obj%NodeID_MainStem) if (obj%NodeID_MainStem(j) == StemNodeID) then exit elseif (obj%MainStem_num_branch(j) /= 0) then branch_id = branch_id + obj%MainStem_num_branch(j) cycle else cycle end if end do else branch_id = 1 end if print *, "Main -> Branch branch id", branch_id if (.not. allocated(obj%NodeID_Branch)) then allocate (obj%NodeID_Branch(obj%MaxStemNum)) end if if (.not. allocated(obj%NodeID_Branch(branch_id)%ID)) then obj%NodeID_Branch(branch_id)%ID = [obj%numStem()] else obj%NodeID_Branch(branch_id)%ID = obj%NodeID_Branch(branch_id)%ID//[obj%numStem()] end if My_StemID = obj%numStem() obj%stem(obj%numStem())%StemID = branch_id call obj%stem(My_StemID)%rotate( & x=radian(random%gauss(mu=obj%br_angle_ave(branch_id), sigma=obj%br_angle_sig(branch_id))), & y=radian(random%gauss(mu=obj%br_angle_ave(branch_id), sigma=obj%br_angle_sig(branch_id))), & z=radian(random%random()*360.0d0) & ) call obj%stem(My_StemID)%change_length_or_width(dt=0.0d0) obj%stem(My_StemID)%StemID = branch_id obj%stem(My_StemID)%InterNodeID = 1 else print *, obj%isMainStem(StemNodeID) print *, mainstem_2_branch print *, "[ERROR] addNode" stop end if call obj%stem(obj%numStem())%connect("=>", obj%stem(StemNodeID)) obj%stem2stem(obj%numStem(), StemNodeID) = 1 ! petiole call obj%stem(obj%numStem() + 1)%init(config=obj%stemconfig) obj%stem(obj%numStem())%StemID = -1 call obj%stem(obj%numStem())%resize( & x=random%gauss(mu=obj%peti_width_ave(i), sigma=obj%peti_width_sig(i)), & y=random%gauss(mu=obj%peti_width_ave(i), sigma=obj%peti_width_sig(i)), & z=random%gauss(mu=obj%peti_size_ave(i), sigma=obj%peti_size_sig(i)) & ) call obj%stem(obj%numStem())%change_length_or_width(dt=0.0d0) call obj%stem(obj%numStem())%rotate( & x=radian(random%gauss(mu=obj%peti_angle_ave(i), sigma=obj%peti_angle_sig(i))), & y=0.0d0, & z=radian(360.0d0*random%random()) & ) !call obj%stem(obj%numStem() )%connect("=>",obj%stem(i)) !obj%stem2stem(obj%numStem() ,i) = 1 call obj%stem(obj%numStem())%connect("=>", obj%stem(obj%numStem() - 1)) obj%stem2stem(obj%numStem(), obj%numStem() - 1) = 1 leaf_z_angles = linspace([0.0d0, 360.0d0], obj%max_num_leaf_per_petiole + 1) do j = 1, obj%max_num_leaf_per_petiole leaf_z_angles(j) = radian(leaf_z_angles(j)) end do leaf_z_angles(:) = leaf_z_angles(:) + radian(random%random()*360.0d0) ! add leaves do j = 1, obj%max_num_leaf_per_petiole obj%num_leaf = obj%num_leaf + 1 call obj%leaf(obj%num_leaf)%init(config=obj%leafconfig, species=PF_GLYCINE_SOJA) call obj%leaf(obj%num_leaf)%resize( & y=random%gauss(mu=obj%leaf_thickness_ave(i), sigma=obj%leaf_thickness_sig(i)), & z=random%gauss(mu=obj%leaf_length_ave(i), sigma=obj%leaf_length_sig(i)), & x=random%gauss(mu=obj%leaf_width_ave(i), sigma=obj%leaf_width_sig(i)) & ) call obj%leaf(obj%num_leaf)%rotate( & x=radian(random%gauss(mu=obj%leaf_angle_ave(i), sigma=obj%leaf_angle_sig(i))), & y=0.0d0, & z=leaf_z_angles(j) & ) call obj%leaf(obj%num_leaf)%connect("=>", obj%stem(obj%numStem())) obj%leaf2stem(obj%num_leaf, obj%numStem()) = 1 call obj%leaf(obj%num_leaf)%change_length_or_width(dt=0.0d0) end do elseif (present(RootNodeID)) then ! set mainroot call obj%root(obj%numRoot() + 1)%init(obj%rootconfig) call obj%root(i)%resize( & x=obj%mr_width, & y=obj%mr_width, & z=obj%mr_length/dble(obj%mr_node) & ) call obj%root(i)%rotate( & x=radian(random%gauss(mu=obj%mr_angle_ave, sigma=obj%mr_angle_sig)), & y=radian(random%gauss(mu=obj%mr_angle_ave, sigma=obj%mr_angle_sig)), & z=radian(random%gauss(mu=obj%mr_angle_ave, sigma=obj%mr_angle_sig)) & ) i = RootNodeID call obj%root(obj%numRoot())%connect("=>", obj%root(i)) obj%root2root(obj%numRoot(), i) = 1 else print *, "ERROR :: add Node ` soybean >> RootNodeID or StemNodeID should be identified." stop end if call obj%update() end subroutine ! ######################################## ! ######################################## subroutine addStemSoybean(obj, stemid, rotx, roty, rotz, json) class(Soybean_), intent(inout) :: obj integer(int32), intent(in) :: stemid character(*), optional, intent(in) :: json real(real64), optional, intent(in) :: rotx, roty, rotz integer(int32) :: i ! add a stem after stem(stemid) do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty() .eqv. .true.) then if (present(json)) then call obj%stem(i)%init(json) call obj%stem(i)%rotate(x=rotx, y=roty, z=rotz) call obj%stem(i)%connect("=>", obj%stem(stemid)) return else call obj%stem(i)%init() call obj%stem(i)%rotate(x=rotx, y=roty, z=rotz) call obj%stem(i)%connect("=>", obj%stem(stemid)) return end if else cycle end if end do end subroutine ! ############################################################# subroutine deformSoybean(obj, displacement, penaltyparameter, groundLevel, disp, & x_min, x_max, y_min, y_max, z_min, z_max) class(Soybean_), target, intent(inout) :: obj ! deform soybean by displacement real(real64), optional, intent(in) :: displacement(:) ! >> regacy real(real64), optional, intent(in) :: groundLevel, disp(3) real(real64), optional, intent(in) :: penaltyparameter, x_min, x_max, y_min, y_max, z_min, z_max type(FEMDomainp_), allocatable :: domainsp(:) integer(int32), allocatable :: contactList(:, :) integer(int32) :: i, j, numDomain, stemDomain, leafDomain, rootDomain, from, to, nd, nn real(real64) :: penalty, GLevel if (present(displacement)) then if (size(displacement) /= obj%nn()*3) then print *, "ERROR :: deformSoybean >> size(displacement) should be (obj%numStem() + obj%numLeaf() + obj%numRoot())*3" return end if ! order :: stem -> leaf -> root from = 1 to = 0 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%Mesh%empty()) then nn = obj%stem(i)%femdomain%nn() nd = obj%stem(i)%femdomain%nd() to = from + obj%stem(i)%femdomain%nn()*obj%stem(i)%femdomain%nd() - 1 obj%stem(i)%femdomain%mesh%nodcoord(:, :) = & obj%stem(i)%femdomain%mesh%nodcoord(:, :) + & reshape(displacement(from:to), nn, nd) from = to + 1 end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%Mesh%empty()) then nn = obj%leaf(i)%femdomain%nn() nd = obj%leaf(i)%femdomain%nd() to = from + obj%leaf(i)%femdomain%nn()*obj%leaf(i)%femdomain%nd() - 1 obj%leaf(i)%femdomain%mesh%nodcoord(:, :) = & obj%leaf(i)%femdomain%mesh%nodcoord(:, :) + & reshape(displacement(from:to), nn, nd) from = to + 1 end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%Mesh%empty()) then nn = obj%root(i)%femdomain%nn() nd = obj%root(i)%femdomain%nd() to = from + obj%root(i)%femdomain%nn()*obj%root(i)%femdomain%nd() - 1 obj%root(i)%femdomain%mesh%nodcoord(:, :) = & obj%root(i)%femdomain%mesh%nodcoord(:, :) + & reshape(displacement(from:to), nn, nd) from = to + 1 end if end do end if return end if ! >> regacy >> if (.not. allocated(obj%Stem)) then print *, "ERROR :: deformSoybean >> no soybean is found!" return end if numDomain = 0 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (obj%root(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 end if end do end if allocate (domainsp(numDomain)) numDomain = 0 stemDomain = 0 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 stemDomain = stemDomain + 1 domainsp(numDomain)%femdomainp => obj%stem(i)%femdomain end if end do end if leafDomain = 0 if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 leafDomain = leafDomain + 1 domainsp(numDomain)%femdomainp => obj%leaf(i)%femdomain end if end do end if rootDomain = 0 if (allocated(obj%root)) then do i = 1, size(obj%root) if (obj%root(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 rootDomain = rootDomain + 1 domainsp(numDomain)%femdomainp => obj%root(i)%femdomain end if end do end if ! (1) create contact-list for all domains contactlist = zeros(numDomain, numDomain) if (allocated(obj%stem2stem)) then do i = 1, stemDomain do j = 1, stemDomain contactlist(i, j) = obj%stem2stem(i, j) end do end do end if if (allocated(obj%leaf2stem)) then do i = 1, leafDomain do j = 1, stemDomain contactlist(i + stemDomain, j) = obj%leaf2stem(i, j) end do end do end if if (allocated(obj%root2stem)) then do i = 1, rootDomain do j = 1, stemDomain contactlist(i + stemDomain + leafDomain, j) = obj%root2stem(i, j) end do end do end if if (allocated(obj%root2root)) then do i = 1, rootDomain do j = 1, rootDomain contactlist(i + stemDomain + leafDomain, j + stemDomain + leafDomain) = obj%root2root(i, j) end do end do end if call obj%contact%init(femdomainsp=domainsp, contactlist=contactlist) ! load material info numDomain = 0 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 call obj%contact%setYoungModulus(YoungModulus=obj%stemYoungModulus(i), DomainID=numDomain) call obj%contact%setPoissonRatio(PoissonRatio=obj%stemPoissonRatio(i), DomainID=numDomain) call obj%contact%setDensity(density=obj%stemDensity(i), DomainID=numDomain) end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 call obj%contact%setYoungModulus(YoungModulus=obj%leafYoungModulus(i), DomainID=numDomain) call obj%contact%setPoissonRatio(PoissonRatio=obj%leafPoissonRatio(i), DomainID=numDomain) call obj%contact%setDensity(density=obj%leafDensity(i), DomainID=numDomain) end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (obj%root(i)%femdomain%mesh%empty()) then cycle else numDomain = numDomain + 1 call obj%contact%setYoungModulus(YoungModulus=obj%rootYoungModulus(i), DomainID=numDomain) call obj%contact%setPoissonRatio(PoissonRatio=obj%rootPoissonRatio(i), DomainID=numDomain) call obj%contact%setDensity(density=obj%rootDensity(i), DomainID=numDomain) end if end do end if ! penalty = input(default=1000.0d0, option=penaltyparameter) call obj%contact%setup(penaltyparameter=penalty) ! if displacement is set, load displacement if (present(disp)) then do i = 1, numDomain call obj%contact%fix(direction="x", disp=disp(1), DomainID=i, & x_min=x_min, x_max=x_max, & y_min=y_min, y_max=y_max, & z_min=z_min, z_max=z_max) call obj%contact%fix(direction="y", disp=disp(2), DomainID=i, & x_min=x_min, x_max=x_max, & y_min=y_min, y_max=y_max, & z_min=z_min, z_max=z_max) call obj%contact%fix(direction="z", disp=disp(3), DomainID=i, & x_min=x_min, x_max=x_max, & y_min=y_min, y_max=y_max, & z_min=z_min, z_max=z_max) end do end if Glevel = input(default=0.0d0, option=groundLevel) ! under-ground parts are fixed. do i = 1, numDomain call obj%contact%fix(direction="x", disp=0.0d0, DomainID=i, & z_max=Glevel) call obj%contact%fix(direction="y", disp=0.0d0, DomainID=i, & z_max=Glevel) call obj%contact%fix(direction="z", disp=0.0d0, DomainID=i, & z_max=Glevel) end do ! solve > get displacement call obj%contact%solver%solve("BiCGSTAB") ! update mesh call obj%contact%updateMesh() end subroutine ! ##################################################################### ! ##################################################################### function getVolumeSoybean(obj, stem, leaf, root) result(ret) class(Soybean_), intent(in) :: obj logical, optional, intent(in) :: stem, leaf, root logical :: all integer(int32) :: i, j real(real64) :: ret all = .false. if (.not. present(stem) .and. .not. present(leaf)) then if (.not. present(root)) then all = .true. end if end if ret = 0.0d0 if (all) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() ret = ret + obj%stem(i)%femdomain%getVolume(elem=j) end do end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() ret = ret + obj%leaf(i)%femdomain%getVolume(elem=j) end do end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() ret = ret + obj%root(i)%femdomain%getVolume(elem=j) end do end if end do return end if if (present(stem)) then if (stem .or. all) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() ret = ret + obj%stem(i)%femdomain%getVolume(elem=j) end do end if end do end if end if if (present(leaf)) then if (leaf) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() ret = ret + obj%leaf(i)%femdomain%getVolume(elem=j) end do end if end do end if end if if (present(root)) then if (root) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() ret = ret + obj%root(i)%femdomain%getVolume(elem=j) end do end if end do end if end if end function ! ############################################################################ ! ##################################################################### function getVolumePerElementSoybean(obj) result(volume) class(Soybean_), intent(in) :: obj integer(int32) :: i, j, elem_id real(real64), allocatable :: volume(:) elem_id = 0 volume = zeros(obj%ne()) do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() elem_id = elem_id + 1 volume(elem_id) = obj%stem(i)%femdomain%getVolume(elem=j) end do end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() elem_id = elem_id + 1 volume(elem_id) = obj%leaf(i)%femdomain%getVolume(elem=j) end do end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() elem_id = elem_id + 1 volume(elem_id) = obj%root(i)%femdomain%getVolume(elem=j) end do end if end do end function ! ############################################################################ ! ############################################################################ function getBiomassSoybean(obj, stem, leaf, root) result(ret) class(Soybean_), intent(in) :: obj logical, optional, intent(in) :: stem, leaf, root logical :: all integer(int32) :: i, j real(real64) :: ret, volume all = .false. if (.not. present(stem) .and. .not. present(leaf)) then if (.not. present(root)) then all = .true. end if end if ret = 0.0d0 if (all) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() volume = obj%stem(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) ret = ret + volume*obj%stem(i)%drydensity(j) end do end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() volume = obj%leaf(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) ret = ret + volume*obj%leaf(i)%drydensity(j) end do end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() volume = obj%root(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) ret = ret + volume*obj%root(i)%drydensity(j) end do end if end do return end if if (present(stem)) then if (stem .or. all) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() volume = obj%stem(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) ret = ret + volume*obj%stem(i)%drydensity(j) end do end if end do end if end if if (present(leaf)) then if (leaf) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() volume = obj%leaf(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) ret = ret + volume*obj%leaf(i)%drydensity(j) end do end if end do end if end if if (present(root)) then if (root) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() volume = obj%root(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) ret = ret + volume*obj%root(i)%drydensity(j) end do end if end do end if end if end function ! ############################################################################ function getElementBiomassSoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: i, j, itr real(real64), allocatable :: ret(:) real(real64) :: volume ret = zeros(obj%ne()) itr = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() volume = obj%stem(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) itr = itr + 1 ret(itr) = volume*obj%stem(i)%drydensity(j) end do end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() volume = obj%leaf(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) itr = itr + 1 ret(itr) = volume*obj%leaf(i)%drydensity(j) end do end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() volume = obj%root(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) itr = itr + 1 ret(itr) = volume*obj%root(i)%drydensity(j) end do end if end do end function function getTotalWeightSoybean(obj, stem, leaf, root, waterDensity) result(ret) class(Soybean_), intent(in) :: obj logical, optional, intent(in) :: stem, leaf, root real(real64), optional, intent(in) :: waterDensity logical :: all integer(int32) :: i, j real(real64) :: ret, volume, water_density ! kg, m water_density = input(default=1000.0d0, option=waterDensity) all = .false. if (.not. present(stem) .and. .not. present(leaf)) then if (.not. present(root)) then all = .true. end if end if ret = 0.0d0 if (all) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() volume = obj%stem(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) + fluid (=watercontent * volume) ret = ret + volume*obj%stem(i)%drydensity(j) + volume*obj%stem(i)%watercontent(j)*water_density end do end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() volume = obj%leaf(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) + fluid (=watercontent * volume) ret = ret + volume*obj%leaf(i)%drydensity(j) + volume*obj%leaf(i)%watercontent(j)*water_density end do end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() volume = obj%root(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) + fluid (=watercontent * volume) ret = ret + volume*obj%root(i)%drydensity(j) + volume*obj%root(i)%watercontent(j)*water_density end do end if end do return end if if (present(stem)) then if (stem .or. all) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then do j = 1, obj%stem(i)%femdomain%ne() volume = obj%stem(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) + fluid (=watercontent * volume) ret = ret + volume*obj%stem(i)%drydensity(j) + volume*obj%stem(i)%watercontent(j)*water_density end do end if end do end if end if if (present(leaf)) then if (leaf) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() volume = obj%leaf(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) + fluid (=watercontent * volume) ret = ret + volume*obj%leaf(i)%drydensity(j) + volume*obj%leaf(i)%watercontent(j)*water_density end do end if end do end if end if if (present(root)) then if (root) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then do j = 1, obj%root(i)%femdomain%ne() volume = obj%root(i)%femdomain%getVolume(elem=j) ! total = total + solid(=drydensity * volume) + fluid (=watercontent * volume) ret = ret + volume*obj%root(i)%drydensity(j) + volume*obj%root(i)%watercontent(j)*water_density end do end if end do end if end if end function !function getBioMassSoybean(obj,stemDensity,leafDensity,rootDensity) result(ret) ! class(Soybean_),intent(in) :: obj ! real(real64),optional,intent(in) :: stemDensity,leafDensity,rootDensity ! logical :: all ! integer(int32) :: i,j ! real(real64) :: ret ! ! ret = 0.0d0 ! ! if(present(stemDensity))then ! ret = ret + obj%getVolume(stem=.true.) * stemDensity ! endif ! ! if(present(leafDensity))then ! ret = ret + obj%getVolume(leaf=.true.) * leafDensity ! endif ! ! if(present(rootDensity))then ! ret = ret + obj%getVolume(root=.true.) * rootDensity ! endif ! ! ! !end function subroutine fall_leafSoybean(obj, BranchID, InterNodeID, with_petiole) class(Soybean_), intent(inout) :: obj integer(int32), intent(in) :: BranchID, InterNodeID logical, optional, intent(in) :: with_petiole integer(int32) :: i, j, stemID integer(int32), allocatable :: petioleIDs(:) ! fall leaves do i = 1, size(obj%stem) if (obj%stem(i)%empty()) cycle if (obj%stem(i)%stemID == branchID .and. & obj%stem(i)%InterNodeID == InterNodeID) then stemID = i end if end do allocate (petioleIDs(0)) do i = 1, size(obj%stem2stem, 1) ! stem id i -> stemID if (obj%stem2stem(i, StemID) /= 0 .and. obj%stem(i)%InterNodeID < 1) then ! petiole petioleIDs = petioleIDs//[i] end if end do print *, "petioleIDs", petioleIDs ! remove leaves do i = 1, size(petioleIDs) do j = 1, size(obj%leaf2stem, 1) if (obj%leaf2stem(j, petioleIDs(i)) /= 0) then obj%leaf2stem(j, petioleIDs(i)) = 0 call obj%leaf(j)%remove() end if end do end do if (present(with_petiole)) then if (with_petiole) then do i = 1, size(petioleIDs) obj%stem2stem(petioleIDs(i), :) = 0 call obj%stem(petioleIDs(i))%remove() end do end if end if end subroutine subroutine removeSoybean(obj, root) class(Soybean_), intent(inout) :: obj logical, optional, intent(in) :: root if (present(root)) then if (root) then obj%mr_node = 0 obj%brr_node(:) = 0 obj%brr_from(:) = 0 obj%mr_length = 0.0d0 obj%brr_length(:) = 0.0d0 obj%mr_width = 0.0d0 obj%brr_width(:) = 0.0d0 obj%mr_angle_ave = 0.0d0 obj%brr_angle_ave(:) = 0.0d0 obj%mr_angle_sig = 0.0d0 obj%brr_angle_sig(:) = 0.0d0 if (allocated(obj%RootSystem)) deallocate (obj%RootSystem) if (allocated(obj%Root)) deallocate (obj%Root) if (allocated(obj%rootYoungModulus)) deallocate (obj%rootYoungModulus) if (allocated(obj%rootPoissonRatio)) deallocate (obj%rootPoissonRatio) if (allocated(obj%rootDensity)) deallocate (obj%rootDensity) if (allocated(obj%root2stem)) deallocate (obj%root2stem) if (allocated(obj%root2root)) deallocate (obj%root2root) if (allocated(obj%root_list)) deallocate (obj%root_list) if (allocated(obj%root_angle)) deallocate (obj%root_angle) obj%rootconfig = " " obj%Num_Of_Root = 0 end if return end if obj%growth_habit = " " obj%growth_stage = " " obj%Num_Of_Node = 0 obj%Num_Of_Root = 0 obj%MaxLeafNum = 300 obj%MaxRootNum = 300 obj%MaxStemNum = 300 obj%ms_node = 0 obj%br_node(:) = 0 obj%br_from(:) = 0 obj%ms_length = 0.0d0 obj%br_length(:) = 0.0d0 obj%ms_width = 0.0d0 obj%br_width(:) = 0.0d0 obj%ms_angle_ave = 0.0d0 obj%br_angle_ave(:) = 0.0d0 obj%ms_angle_sig = 0.0d0 obj%br_angle_sig(:) = 0.0d0 obj%mr_node = 0 obj%brr_node(:) = 0 obj%brr_from(:) = 0 obj%mr_length = 0.0d0 obj%brr_length(:) = 0.0d0 obj%mr_width = 0.0d0 obj%brr_width(:) = 0.0d0 obj%mr_angle_ave = 0.0d0 obj%brr_angle_ave(:) = 0.0d0 obj%mr_angle_sig = 0.0d0 obj%brr_angle_sig(:) = 0.0d0 obj%peti_size_ave(:) = 0.0d0 obj%peti_size_sig(:) = 0.0d0 obj%peti_width_ave(:) = 0.0d0 obj%peti_width_sig(:) = 0.0d0 obj%peti_angle_ave(:) = 0.0d0 obj%peti_angle_sig(:) = 0.0d0 obj%leaf_angle_ave(:) = 0.0d0 obj%leaf_angle_sig(:) = 0.0d0 obj%leaf_length_ave(:) = 0.0d0 obj%leaf_length_sig(:) = 0.0d0 obj%leaf_width_ave(:) = 0.0d0 obj%leaf_width_sig(:) = 0.0d0 obj%leaf_thickness_ave(:) = 0.0d0 obj%leaf_thickness_sig(:) = 0.0d0 obj%Stage = "" ! VE, CV, V1,V2, ..., R1, R2, ..., R8 obj%name = "" obj%stage_id = 0 obj%dt = 0.0d0 call obj%Seed%remove() if (allocated(obj%NodeSystem)) deallocate (obj%NodeSystem) if (allocated(obj%RootSystem)) deallocate (obj%RootSystem) if (allocated(obj%Stem)) deallocate (obj%Stem) if (allocated(obj%Leaf)) deallocate (obj%Leaf) if (allocated(obj%Root)) deallocate (obj%Root) ! material info if (allocated(obj%stemYoungModulus)) deallocate (obj%stemYoungModulus) if (allocated(obj%leafYoungModulus)) deallocate (obj%leafYoungModulus) if (allocated(obj%rootYoungModulus)) deallocate (obj%rootYoungModulus) if (allocated(obj%stemPoissonRatio)) deallocate (obj%stemPoissonRatio) if (allocated(obj%leafPoissonRatio)) deallocate (obj%leafPoissonRatio) if (allocated(obj%rootPoissonRatio)) deallocate (obj%rootPoissonRatio) if (allocated(obj%stemDensity)) deallocate (obj%stemDensity) if (allocated(obj%leafDensity)) deallocate (obj%leafDensity) if (allocated(obj%rootDensity)) deallocate (obj%rootDensity) if (allocated(obj%NodeID_MainStem)) deallocate (obj%NodeID_MainStem) if (allocated(obj%NodeID_Branch)) deallocate (obj%NodeID_Branch) ! 節-節点データ構造 call obj%struct%remove(all=.true.) if (allocated(obj%leaf2stem)) deallocate (obj%leaf2stem) if (allocated(obj%stem2stem)) deallocate (obj%stem2stem) if (allocated(obj%root2stem)) deallocate (obj%root2stem) if (allocated(obj%root2root)) deallocate (obj%root2root) ! 器官オブジェクト配列 if (allocated(obj%leaf_list)) deallocate (obj%leaf_list) if (allocated(obj%stem_list)) deallocate (obj%stem_list) if (allocated(obj%root_list)) deallocate (obj%root_list) ! シミュレータ call obj%contact%remove() obj%time = 0.0d0 obj%seed_length = 0.0d0 obj%seed_width = 0.0d0 obj%seed_height = 0.0d0 if (allocated(obj%stem_angle)) deallocate (obj%stem_angle) if (allocated(obj%root_angle)) deallocate (obj%root_angle) if (allocated(obj%leaf_angle)) deallocate (obj%leaf_angle) obj%stemconfig = " " obj%rootconfig = " " obj%leafconfig = " " end subroutine function stemlengthSoybean(obj, StemID) result(ret) class(Soybean_), intent(inout) :: obj integer(int32), intent(in) :: StemID ! 0, 1, 2... integer(int32) :: num_snode, i real(real64), allocatable :: ret(:) if (StemID == 0) then ! main stem num_snode = size(obj%NodeID_MainStem) allocate (ret(num_snode)) do i = 1, num_snode ret(i) = obj%stem(obj%NodeID_MainStem(i))%getLength() end do else if (StemID >= size(obj%NodeID_Branch)) then print *, "ERROR :: stemlengthSoybean >> StemID >=size(obj%NodeID_Branch)" ret = zeros(1) return end if ! main stem num_snode = size(obj%NodeID_Branch(StemID)%ID) allocate (ret(num_snode)) do i = 1, num_snode ret(i) = obj%stem(obj%NodeID_Branch(StemID)%ID(i))%getLength() end do end if end function ! ################################################################### ! object editor ! rotateStem ! rotateRoot ! rotateLeaf ! resizeStem(MainStem) ! resizeRoot ! resizeLeaf ! ################################################################### subroutine resizeSoybean(obj, StemID, StemLength) class(Soybean_), intent(inout) :: obj integer(int32), optional, intent(in) :: StemID real(real64), optional, intent(in) :: StemLength(:) integer(int32) :: num_snode, i if (present(StemID)) then if (.not. present(StemLength)) then print *, "ERROR :: resizeSoybean >> needs StemLength(:) " stop end if if (StemID == 0) then ! main stem num_snode = size(obj%NodeID_MainStem) do i = 1, num_snode call obj%stem(obj%NodeID_MainStem(i))%change_length_or_width(length=StemLength(i)) end do else if (StemID >= size(obj%NodeID_Branch)) then print *, "ERROR :: resizeSoybean >> StemID >=size(obj%NodeID_Branch)" return end if ! main stem num_snode = size(obj%NodeID_Branch(StemID)%ID) do i = 1, num_snode call obj%stem(obj%NodeID_Branch(StemID)%ID(i))%change_length_or_width(length=StemLength(i)) end do end if call obj%update() end if end subroutine ! ################################################################### ! ################################################################### function NumberOfBranchSoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: ret, i ret = 0 if (allocated(obj%NodeID_Branch)) then do i = 1, size(obj%NodeID_Branch) if (allocated(obj%NodeID_Branch(i)%ID)) then if (size(obj%NodeID_Branch(i)%ID) >= 1) then ret = ret + 1 end if end if end do end if end function ! ################################################################### ! ################################################################### function findApicalSoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32), allocatable :: ret(:) !integer(int32),optional,intent(in) :: StemID integer(int32), allocatable :: stem integer(int32) :: i, j, itr ret = zeros(obj%NumberOfBranch() + 1) ret(1) = maxval(obj%NodeID_MainStem(:)) itr = 1 do i = 1, obj%NumberOfBranch() if (allocated(obj%NodeID_Branch(i)%ID)) then itr = itr + 1 ret(itr) = maxval(obj%NodeID_Branch(i)%ID(:)) end if end do ! if(present(StemID) )then ! if(StemID > size(obj%br_node) )then ! print *, "ERROR >> findApicalSoybean >> number of branch is ",size(obj%br_node) ! print *, "StemID=",StemID,"is larger than it." ! return ! endif ! ! ! return ! endif end function ! ################################################################### !function propertiesSoybean(obj) result(ret) ! class(Soybean_) ,intent(in) :: obj ! ! !end function ! ################################################################## pure function nnSoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: ret, i ! get number of node (point) ret = 0 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then ret = ret + obj%stem(i)%femdomain%nn() end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then ret = ret + obj%leaf(i)%femdomain%nn() end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then ret = ret + obj%root(i)%femdomain%nn() end if end do end if end function ! ################################################################## ! ################################################################## function neSoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: ret, i ! get number of element ret = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then ret = ret + obj%stem(i)%femdomain%ne() end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then ret = ret + obj%leaf(i)%femdomain%ne() end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then ret = ret + obj%root(i)%femdomain%ne() end if end do end function ! ################################################################## ! ################################################################## function nsSoybean(obj) result(ret) class(Soybean_), intent(in) :: obj integer(int32) :: ret, i ! get number of subdomain ret = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then ret = ret + 1 end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then ret = ret + 1 end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then ret = ret + 1 end if end do end function ! ################################################################## function getSubDomainSoybean(obj, id) result(ret) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: id type(FEMDomain_) :: ret integer(int32) :: i, ret_id ! get number of subdomain ret_id = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then ret_id = ret_id + 1 if (id == ret_id) then ret = obj%stem(i)%femdomain return end if end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then ret_id = ret_id + 1 if (id == ret_id) then ret = obj%stem(i)%femdomain return end if end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then ret_id = ret_id + 1 if (id == ret_id) then ret = obj%stem(i)%femdomain return end if end if end do print *, "Caution >> getSubDomainSoybean >> exceed total number of subdomains", ret_id return end function ! ################################################################## ! ################################################################## subroutine setSubDomainSoybean(obj, domain, id) class(Soybean_), intent(inout) :: obj type(FEMDomain_), intent(in) :: domain integer(int32), intent(in) :: id integer(int32) :: i, domain_id ! get number of subdomain domain_id = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then domain_id = domain_id + 1 if (id == domain_id) then obj%stem(i)%femdomain = domain return end if end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then domain_id = domain_id + 1 if (id == domain_id) then obj%stem(i)%femdomain = domain return end if end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then domain_id = domain_id + 1 if (id == domain_id) then obj%stem(i)%femdomain = domain return end if end if end do print *, "Caution >> getSubDomainSoybean >> exceed total number of subdomains", domain_id return end subroutine ! ################################################################## ! ################################################################## function getSubDomainTypeSoybean(obj, id) result(ret) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: id character(:), allocatable :: ret integer(int32) :: i, ret_id ! get number of subdomain ret_id = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%mesh%empty()) then ret_id = ret_id + 1 if (id == ret_id) then ret = "stem" return end if end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%mesh%empty()) then ret_id = ret_id + 1 if (id == ret_id) then ret = "leaf" return end if end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%mesh%empty()) then ret_id = ret_id + 1 if (id == ret_id) then ret = "root" return end if end if end do print *, "Caution >> getSubDomainSoybean >> exceed total number of subdomains", ret_id return end function ! ################################################################## ! ################################################################## pure function isMainStemSoybean(obj, StemNodeID) result(ret) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: StemNodeID logical :: ret ret = exists(vector=obj%NodeID_MainStem, val=StemNodeID) end function ! ################################################################## ! ################################################################## pure function isBranchStemSoybean(obj, StemNodeID) result(ret) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: StemNodeID logical :: ret if (obj%branchID(StemNodeID) == 0) then ret = .False. else ret = .True. end if end function ! ################################################################## pure function branchIDSoybean(obj, StemNodeID) result(ret) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: StemNodeID integer(int32), allocatable :: ret integer(int32) :: i, j, k, l, m, n, ret_id do i = 1, size(obj%NodeID_Branch) if (exist(obj%NodeID_Branch(i)%ID(:), StemNodeID)) then ret = i return end if end do ret = 0 end function ! ################################################################## subroutine checkPropertiesSoybean(obj, Simulator) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: Simulator type(Time_) :: time type(IO_) :: f call f%open("__soybeanclass__checkPropertiesSoybean.log") if (Simulator == PF_DEFORMATION_ANALYSIS) then call print("---------------------------------------") call print("-- checkProperties @ SoybeanClass ----") call print("---------------------------------------") call print(" Simulator mode :: Deformation analysis") call print("---------------------------------------") call print("Date and time: "//time%DateAndTime()) call print("---------------------------------------") call print("Checking datasets for deformation analysis...") ! check if it ready or not. print *, "property_deform_material_density |", & obj%property_deform_material_density print *, "property_deform_material_YoungModulus |", & obj%property_deform_material_YoungModulus print *, "property_deform_material_CarbonDiffusionCoefficient|", & obj%property_deform_material_CarbonDiffusionCoefficient print *, "property_deform_material_PoissonRatio |", & obj%property_deform_material_PoissonRatio print *, "property_deform_initial_Displacement |", & obj%property_deform_initial_Displacement print *, "property_deform_initial_Stress |", & obj%property_deform_initial_Stress print *, "property_deform_boundary_TractionForce |", & obj%property_deform_boundary_TractionForce print *, "property_deform_boundary_Displacement |", & obj%property_deform_boundary_Displacement print *, "property_deform_gravity |", & obj%property_deform_gravity call print("---------------------------------------") ! >>>> export to log call f%write("---------------------------------------") call f%write("-- checkProperties @ SoybeanClass ----") call f%write("---------------------------------------") call f%write(" Simulator mode :: Deformation analysis") call f%write("---------------------------------------") call f%write("Date and time: "//time%DateAndTime()) call f%write("---------------------------------------") call f%write("Checking datasets for deformation analysis...") ! check if it ready or not. call f%write("property_deform_material_density |"// & str(obj%property_deform_material_density)) call f%write("property_deform_material_YoungModulus |"// & str(obj%property_deform_material_YoungModulus)) call f%write("property_deform_material_CarbonDiffusionCoefficient |"// & str(obj%property_deform_material_CarbonDiffusionCoefficient)) call f%write("property_deform_material_PoissonRatio |"// & str(obj%property_deform_material_PoissonRatio)) call f%write("property_deform_initial_Displacement |"// & str(obj%property_deform_initial_Displacement)) call f%write("property_deform_initial_Stress |"// & str(obj%property_deform_initial_Stress)) call f%write("property_deform_boundary_TractionForce |"// & str(obj%property_deform_boundary_TractionForce)) call f%write("property_deform_boundary_Displacement |"// & str(obj%property_deform_boundary_Displacement)) call f%write("property_deform_gravity |"// & str(obj%property_deform_gravity)) call f%write("---------------------------------------") else call print("Invalid Simulator ID :: "//str(Simulator)) end if call f%close() end subroutine ! ################################################################## ! ################################################################## subroutine setPropertiesDensitySoybean(obj) class(Soybean_), intent(inout) :: obj integer(int32) :: i, j ! default == false obj%property_deform_material_density = .false. ! check ! Does stem/leaf/root have Density for each element? if (allocated(obj%leaf)) then print *, "[ok] setPropertiesSoybean >> leaf exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! exists ! check ! (1) allocation of density(:) ! (2) size of density(:) ! if invalid, compute from drydensity(:)and watercontent(:) ! if not both do not exists, create all as 0.0 if (allocated(obj%leaf(i)%density)) then ! check size !if(size(obj%leaf(i)%density)/=obj%leaf(i)%femdomain%ne() )then !print *, "[Caution] setPropertiesSoybean >> stem("//str(i)//")%density >> "//& !"size(obj%leaf(i)%density)/=obj%leaf(i)%femdomain%ne() >> reset by zero!!" !deallocate(obj%leaf(i)%density) ! let's go to next !else print *, "[ok] setPropertiesSoybean & & >> leaf("//str(i)//")%density >> allocated" ! then ok. let's return obj%property_deform_material_density = .true. !endif else ! density is not allocated. obj%leaf(i)%density = zeros(obj%leaf(i)%femdomain%ne()) ! >> try to compute from drydensity(:) and watercontent(:) ! >> check existatce of drydensity(:) and watercontent(:) if (.not. allocated(obj%leaf(i)%drydensity)) then obj%leaf(i)%drydensity = zeros(obj%leaf(i)%femdomain%ne()) end if if (.not. allocated(obj%leaf(i)%watercontent)) then obj%leaf(i)%watercontent = zeros(obj%leaf(i)%femdomain%ne()) end if if (size(obj%leaf(i)%drydensity) /= obj%leaf(i)%femdomain%ne()) then obj%leaf(i)%drydensity = zeros(obj%leaf(i)%femdomain%ne()) end if if (size(obj%leaf(i)%watercontent) /= obj%leaf(i)%femdomain%ne()) then obj%leaf(i)%watercontent = zeros(obj%leaf(i)%femdomain%ne()) end if ! compute density from drydensity and water content ! \rho_t = \rho_d * (1 - w ) !!$OMP parallel do private(j) do j = 1, obj%leaf(i)%femdomain%ne() obj%leaf(i)%density(j) = obj%leaf(i)%drydensity(j)*(1.0d0 - obj%leaf(i)%watercontent(j)) end do !!$OMP end parallel do end if end if end do !!$OMP end parallel do obj%property_deform_material_density = .true. else print *, "[Notice] setPropertiesSoybean >> no leaf" end if !! stem if (allocated(obj%stem)) then print *, "[ok] setPropertiesSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! exists ! check ! (1) allocation of density(:) ! (2) size of density(:) ! if invalid, compute from drydensity(:)and watercontent(:) ! if not both do not exists, create all as 0.0 if (allocated(obj%stem(i)%density)) then ! check size !if(size(obj%stem(i)%density)/=obj%stem(i)%femdomain%ne() )then !print *, "[Caution] setPropertiesSoybean >> stem("//str(i)//")%density >> "//& !"size(obj%stem(i)%density)/=obj%stem(i)%femdomain%ne() >> reset by zero!!" !deallocate(obj%stem(i)%density) ! let's go to next !else print *, "[ok] setPropertiesSoybean >> stem("//str(i)//")%density >> allocated" ! then ok. let's return obj%property_deform_material_density = .true. !endif else ! density is not allocated. obj%stem(i)%density = zeros(obj%stem(i)%femdomain%ne()) ! >> try to compute from drydensity(:) and watercontent(:) ! >> check existatce of drydensity(:) and watercontent(:) if (.not. allocated(obj%stem(i)%drydensity)) then obj%stem(i)%drydensity = zeros(obj%stem(i)%femdomain%ne()) end if if (.not. allocated(obj%stem(i)%watercontent)) then obj%stem(i)%watercontent = zeros(obj%stem(i)%femdomain%ne()) end if if (size(obj%stem(i)%drydensity) /= obj%stem(i)%femdomain%ne()) then obj%stem(i)%drydensity = zeros(obj%stem(i)%femdomain%ne()) end if if (size(obj%stem(i)%watercontent) /= obj%stem(i)%femdomain%ne()) then obj%stem(i)%watercontent = zeros(obj%stem(i)%femdomain%ne()) end if ! compute density from drydensity and water content ! \rho_t = \rho_d * (1 - w ) !!$OMP parallel do private(j) do j = 1, obj%stem(i)%femdomain%ne() obj%stem(i)%density(j) = obj%stem(i)%drydensity(j)*(1.0d0 - obj%stem(i)%watercontent(j)) end do !!$OMP end parallel do end if end if end do !!$OMP end parallel do obj%property_deform_material_density = .true. else print *, "[Notice] setPropertiesSoybean >> no stems" end if !! root if (allocated(obj%root)) then print *, "[ok] setPropertiesSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! exists ! check ! (1) allocation of density(:) ! (2) size of density(:) ! if invalid, compute from drydensity(:)and watercontent(:) ! if not both do not exists, create all as 0.0 if (allocated(obj%root(i)%density)) then ! check size !if(size(obj%root(i)%density)/=obj%root(i)%femdomain%ne() )then !print *, "[Caution] setPropertiesSoybean >> root("//str(i)//")%density >> "//& !"size(obj%root(i)%density)/=obj%root(i)%femdomain%ne() >> reset by zero!!" !deallocate(obj%root(i)%density) ! let's go to next !else print *, "[ok] setPropertiesSoybean >> root("//str(i)//")%density >> allocated" ! then ok. let's return obj%property_deform_material_density = .true. !endif else ! density is not allocated. obj%root(i)%density = zeros(obj%root(i)%femdomain%ne()) ! >> try to compute from drydensity(:) and watercontent(:) ! >> check existatce of drydensity(:) and watercontent(:) if (.not. allocated(obj%root(i)%drydensity)) then obj%root(i)%drydensity = zeros(obj%root(i)%femdomain%ne()) end if if (.not. allocated(obj%root(i)%watercontent)) then obj%root(i)%watercontent = zeros(obj%root(i)%femdomain%ne()) end if if (size(obj%root(i)%drydensity) /= obj%root(i)%femdomain%ne()) then obj%root(i)%drydensity = zeros(obj%root(i)%femdomain%ne()) end if if (size(obj%root(i)%watercontent) /= obj%root(i)%femdomain%ne()) then obj%root(i)%watercontent = zeros(obj%root(i)%femdomain%ne()) end if ! compute density from drydensity and water content ! \rho_t = \rho_d * (1 - w ) !!$OMP parallel do private(j) do j = 1, obj%root(i)%femdomain%ne() obj%root(i)%density(j) = obj%root(i)%drydensity(j)*(1.0d0 - obj%root(i)%watercontent(j)) end do !!$OMP end parallel do end if end if end do !!$OMP end parallel do obj%property_deform_material_density = .true. else print *, "[Notice] setPropertiesSoybean >> no roots" end if end subroutine ! ################################################################## subroutine setPropertiesYoungModulusSoybean(obj, default_value) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value real(real64) :: defval integer(int32) :: i, j defval = input(default=0.0d0, option=default_value) if (allocated(obj%stem)) then print *, "[ok] setPropertiesYoungModulusSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! allocate youngmoludus if stem(i) exists and not allocated ! the default value is defval if (allocated(obj%stem(i)%youngmodulus)) then print *, "[ok] setPropertiesYoungModulusSoybean >> stem("//str(i)//")%youngmodulus >> allocated" ! then ok. let's return obj%property_deform_material_youngmodulus = .true. else ! youngmodulus is not allocated. obj%stem(i)%youngmodulus = zeros(obj%stem(i)%femdomain%ne()) obj%stem(i)%youngmodulus = defval end if end if end do end if ! same as this if (allocated(obj%root)) then print *, "[ok] setPropertiesYoungModulusSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! allocate youngmoludus if root(i) exists and not allocated ! the default value is defval if (allocated(obj%root(i)%youngmodulus)) then print *, "[ok] setPropertiesYoungModulusSoybean >> root("//str(i)//")%youngmodulus >> allocated" ! then ok. let's return obj%property_deform_material_youngmodulus = .true. else ! youngmodulus is not allocated. obj%root(i)%youngmodulus = zeros(obj%root(i)%femdomain%ne()) obj%root(i)%youngmodulus = defval end if end if end do end if ! same for leaf if (allocated(obj%leaf)) then print *, "[ok] setPropertiesYoungModulusSoybean >> leafs exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! allocate youngmoludus if leaf(i) exists and not allocated ! the default value is defval if (allocated(obj%leaf(i)%youngmodulus)) then print *, "[ok] setPropertiesYoungModulusSoybean & & >> leaf("//str(i)//")%youngmodulus >> allocated" ! then ok. let's return obj%property_deform_material_youngmodulus = .true. else ! youngmodulus is not allocated. obj%leaf(i)%youngmodulus = zeros(obj%leaf(i)%femdomain%ne()) obj%leaf(i)%youngmodulus = defval end if end if end do end if obj%property_deform_material_youngmodulus = .true. end subroutine ! ################################################################## ! ################################################################## subroutine setPropertiesCarbonDiffusionCoefficientSoybean(obj, default_value) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value real(real64) :: defval integer(int32) :: i, j defval = input(default=0.0d0, option=default_value) if (allocated(obj%stem)) then print *, "[ok] setPropertiesCarbonDiffusionCoefficientSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! allocate youngmoludus if stem(i) exists and not allocated ! the default value is defval if (allocated(obj%stem(i)%CarbonDiffusionCoefficient)) then print *, "[ok] setPropertiesCarbonDiffusionCoefficientSoybean >> & & stem("//str(i)//")%CarbonDiffusionCoefficient >> allocated" ! then ok. let's return obj%property_deform_material_CarbonDiffusionCoefficient = .true. else ! CarbonDiffusionCoefficient is not allocated. obj%stem(i)%CarbonDiffusionCoefficient = zeros(obj%stem(i)%femdomain%ne()) obj%stem(i)%CarbonDiffusionCoefficient = defval end if end if end do end if ! same as this if (allocated(obj%root)) then print *, "[ok] setPropertiesCarbonDiffusionCoefficientSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! allocate youngmoludus if root(i) exists and not allocated ! the default value is defval if (allocated(obj%root(i)%CarbonDiffusionCoefficient)) then print *, "[ok] setPropertiesCarbonDiffusionCoefficientSoybean & & >> root("//str(i)//")%CarbonDiffusionCoefficient >> allocated" ! then ok. let's return obj%property_deform_material_CarbonDiffusionCoefficient = .true. else ! CarbonDiffusionCoefficient is not allocated. obj%root(i)%CarbonDiffusionCoefficient = zeros(obj%root(i)%femdomain%ne()) obj%root(i)%CarbonDiffusionCoefficient = defval end if end if end do end if ! same for leaf if (allocated(obj%leaf)) then print *, "[ok] setPropertiesCarbonDiffusionCoefficientSoybean >> leafs exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! allocate youngmoludus if leaf(i) exists and not allocated ! the default value is defval if (allocated(obj%leaf(i)%CarbonDiffusionCoefficient)) then print *, "[ok] setPropertiesCarbonDiffusionCoefficientSoybean & & >> leaf("//str(i)//")%CarbonDiffusionCoefficient >> allocated" ! then ok. let's return obj%property_deform_material_CarbonDiffusionCoefficient = .true. else ! CarbonDiffusionCoefficient is not allocated. obj%leaf(i)%CarbonDiffusionCoefficient = zeros(obj%leaf(i)%femdomain%ne()) obj%leaf(i)%CarbonDiffusionCoefficient = defval end if end if end do end if obj%property_deform_material_CarbonDiffusionCoefficient = .true. end subroutine ! ################################################################## ! ################################################################## !same for poissonratio subroutine setPropertiesPoissonRatioSoybean(obj, default_value) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value real(real64) :: defval integer(int32) :: i, j defval = input(default=0.0d0, option=default_value) if (allocated(obj%stem)) then print *, "[ok] setPropertiesPoissonRatioSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! allocate youngmoludus if stem(i) exists and not allocated ! the default value is defval if (allocated(obj%stem(i)%poissonratio)) then print *, "[ok] setPropertiesPoissonRatioSoybean >> stem("//str(i)//")%poissonratio >> allocated" ! then ok. let's return obj%property_deform_material_poissonratio = .true. else ! youngmodulus is not allocated. obj%stem(i)%poissonratio = zeros(obj%stem(i)%femdomain%ne()) obj%stem(i)%poissonratio = defval end if end if end do !!$OMP end parallel do end if ! same for leaf if (allocated(obj%leaf)) then print *, "[ok] setPropertiesPoissonRatioSoybean >> leafs exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! allocate youngmoludus if leaf(i) exists and not allocated ! the default value is defval if (allocated(obj%leaf(i)%poissonratio)) then print *, "[ok] setPropertiesPoissonRatioSoybean >> leaf("//str(i)//")%poissonratio >> allocated" ! then ok. let's return obj%property_deform_material_poissonratio = .true. else ! youngmodulus is not allocated. obj%leaf(i)%poissonratio = zeros(obj%leaf(i)%femdomain%ne()) obj%leaf(i)%poissonratio = defval end if end if end do !!$OMP end parallel do end if ! same for root if (allocated(obj%root)) then print *, "[ok] setPropertiesPoissonRatioSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! allocate youngmoludus if root(i) exists and not allocated ! the default value is defval if (allocated(obj%root(i)%poissonratio)) then print *, "[ok] setPropertiesPoissonRatioSoybean >> root("//str(i)//")%poissonratio >> allocated" ! then ok. let's return obj%property_deform_material_poissonratio = .true. else ! youngmodulus is not allocated. obj%root(i)%poissonratio = zeros(obj%root(i)%femdomain%ne()) obj%root(i)%poissonratio = defval end if end if end do !!$OMP end parallel do end if obj%property_deform_material_poissonratio = .true. end subroutine ! ################################################################## ! similar subroutine for Initialdisplacement subroutine setPropertiesInitialDisplacementSoybean(obj, default_value) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value real(real64) :: defval integer(int32) :: i, j defval = input(default=0.0d0, option=default_value) if (allocated(obj%stem)) then print *, "[ok] setPropertiesInitialDisplacementSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! allocate youngmoludus if stem(i) exists and not allocated ! the default value is defval if (allocated(obj%stem(i)%Displacement)) then print *, "[ok] setPropertiesInitialDisplacementSoybean >> & & stem("//str(i)//")%Displacement >> allocated" ! then ok. let's return obj%property_deform_initial_displacement = .true. else ! youngmodulus is not allocated. obj%stem(i)%Displacement = zeros(obj%stem(i)%femdomain%nn(), 3) obj%stem(i)%Displacement = defval end if end if end do !!$OMP end parallel do end if ! same for leaf if (allocated(obj%leaf)) then print *, "[ok] setPropertiesInitialDisplacementSoybean >> leafs exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! allocate youngmoludus if leaf(i) exists and not allocated ! the default value is defval if (allocated(obj%leaf(i)%Displacement)) then print *, "[ok] setPropertiesInitialDisplacementSoybean >> leaf("//str(i)//")%Displacement >> allocated" ! then ok. let's return obj%property_deform_initial_displacement = .true. else ! youngmodulus is not allocated. obj%leaf(i)%Displacement = zeros(obj%leaf(i)%femdomain%nn(), 3) obj%leaf(i)%Displacement = defval end if end if end do !!$OMP end parallel do end if ! same for root if (allocated(obj%root)) then print *, "[ok] setPropertiesInitialDisplacementSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! allocate youngmoludus if root(i) exists and not allocated ! the default value is defval if (allocated(obj%root(i)%Displacement)) then print *, "[ok] setPropertiesInitialDisplacementSoybean >> root("//str(i)//")%Displacement >> allocated" ! then ok. let's return obj%property_deform_initial_displacement = .true. else ! youngmodulus is not allocated. obj%root(i)%Displacement = zeros(obj%root(i)%femdomain%nn(), 3) obj%root(i)%Displacement = defval end if end if end do !!$OMP end parallel do end if obj%property_deform_initial_displacement = .true. end subroutine ! same for initialstress but dimension = 3 subroutine setPropertiesInitialStressSoybean(obj, default_value) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value real(real64) :: defval integer(int32) :: i, j defval = input(default=0.0d0, option=default_value) if (allocated(obj%stem)) then print *, "[ok] setPropertiesInitialStressSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! allocate youngmoludus if stem(i) exists and not allocated ! the default value is defval if (allocated(obj%stem(i)%stress)) then print *, "[ok] setPropertiesInitialStressSoybean >> & & stem("//str(i)//")%stress >> allocated" ! then ok. let's return obj%property_deform_initial_stress = .true. else ! youngmodulus is not allocated. obj%stem(i)%stress = zeros(obj%stem(i)%femdomain%ne(), obj%stem(i)%femdomain%nne(), 6) obj%stem(i)%stress = defval end if end if end do !!$OMP end parallel do end if ! same for leaf if (allocated(obj%leaf)) then print *, "[ok] setPropertiesInitialStressSoybean >> leafs exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! allocate youngmoludus if leaf(i) exists and not allocated ! the default value is defval if (allocated(obj%leaf(i)%stress)) then print *, "[ok] setPropertiesInitialStressSoybean >> leaf("//str(i)//")%stress >> allocated" ! then ok. let's return obj%property_deform_initial_stress = .true. else ! youngmodulus is not allocated. obj%leaf(i)%stress = zeros(obj%leaf(i)%femdomain%ne(), obj%leaf(i)%femdomain%nne(), 6) obj%leaf(i)%stress = defval end if end if end do !!$OMP end parallel do end if ! same for root if (allocated(obj%root)) then print *, "[ok] setPropertiesInitialStressSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! allocate youngmoludus if root(i) exists and not allocated ! the default value is defval if (allocated(obj%root(i)%stress)) then print *, "[ok] setPropertiesInitialStressSoybean >> root("//str(i)//")%stress >> allocated" ! then ok. let's return obj%property_deform_initial_stress = .true. else ! youngmodulus is not allocated. obj%root(i)%stress = zeros(obj%root(i)%femdomain%ne(), obj%root(i)%femdomain%nne(), 6) obj%root(i)%stress = defval end if end if end do !!$OMP end parallel do end if obj%property_deform_initial_stress = .true. end subroutine ! ################################################################################ ! same as initdisplacement for BoundaryTractionForce subroutine setPropertiesBoundaryTractionForceSoybean(obj, default_value, xrange, yrange, zrange) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value, xrange(2), yrange(2), zrange(2) real(real64) :: defval integer(int32) :: i, j defval = input(default=0.0d0, option=default_value) if (allocated(obj%stem)) then print *, "[ok] setPropertiesBoundaryTractionForceSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! allocate youngmoludus if stem(i) exists and not allocated ! the default value is defval if (allocated(obj%stem(i)%BoundaryTractionForce)) then print *, "[ok] setPropertiesBoundaryTractionForceSoybean >> & & stem("//str(i)//")%BoundaryTractionForce >> allocated" ! then ok. let's return obj%property_deform_boundary_tractionforce = .true. else ! youngmodulus is not allocated. obj%stem(i)%BoundaryTractionForce = zeros(obj%stem(i)%femdomain%nn(), 3) obj%stem(i)%BoundaryTractionForce = defval end if end if end do !!$OMP end parallel do end if ! same for leaf if (allocated(obj%leaf)) then print *, "[ok] setPropertiesBoundaryTractionForceSoybean >> leafs exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! allocate youngmoludus if leaf(i) exists and not allocated ! the default value is defval if (allocated(obj%leaf(i)%BoundaryTractionForce)) then print *, "[ok] setPropertiesBoundaryTractionForceSoybean & & >> leaf("//str(i)//")%BoundaryTractionForce >> allocated" ! then ok. let's return obj%property_deform_boundary_tractionforce = .true. else ! youngmodulus is not allocated. obj%leaf(i)%BoundaryTractionForce = zeros(obj%leaf(i)%femdomain%nn(), 3) obj%leaf(i)%BoundaryTractionForce = defval end if end if end do !!$OMP end parallel do end if ! same for root if (allocated(obj%root)) then print *, "[ok] setPropertiesBoundaryTractionForceSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! allocate youngmoludus if root(i) exists and not allocated ! the default value is defval if (allocated(obj%root(i)%BoundaryTractionForce)) then print *, "[ok] setPropertiesBoundaryTractionForceSoybean & & >> root("//str(i)//")%BoundaryTractionForce >> allocated" ! then ok. let's return obj%property_deform_boundary_tractionforce = .true. else ! youngmodulus is not allocated. obj%root(i)%BoundaryTractionForce = zeros(obj%root(i)%femdomain%nn(), 3) obj%root(i)%BoundaryTractionForce = defval end if end if end do !!$OMP end parallel do end if obj%property_deform_boundary_tractionforce = .true. end subroutine ! ################################################################## ! ################################################################################ ! same as initdisplacement for BoundaryTractionForce subroutine setPropertiesBoundaryDisplacementSoybean(obj, default_value, xrange, yrange, zrange) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value, xrange(2), yrange(2), zrange(2) real(real64) :: defval integer(int32) :: i, j defval = input(default=0.0d0, option=default_value) if (allocated(obj%stem)) then print *, "[ok] setPropertiesBoundaryDisplacementSoybean >> stems exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else ! allocate youngmoludus if stem(i) exists and not allocated ! the default value is defval if (allocated(obj%stem(i)%BoundaryDisplacement)) then print *, "[ok] setPropertiesBoundaryDisplacementSoybean >> & & stem("//str(i)//")%BoundaryDisplacement >> allocated" ! then ok. let's return obj%property_deform_boundary_displacement = .true. else ! youngmodulus is not allocated. obj%stem(i)%BoundaryDisplacement = zeros(obj%stem(i)%femdomain%nn(), 3) obj%stem(i)%BoundaryDisplacement = defval end if end if end do !!$OMP end parallel do end if ! same for leaf if (allocated(obj%leaf)) then print *, "[ok] setPropertiesBoundaryDisplacementSoybean >> leafs exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else ! allocate youngmoludus if leaf(i) exists and not allocated ! the default value is defval if (allocated(obj%leaf(i)%BoundaryDisplacement)) then print *, "[ok] setPropertiesBoundaryDisplacementSoybean & & >> leaf("//str(i)//")%BoundaryDisplacement >> allocated" ! then ok. let's return obj%property_deform_boundary_Displacement = .true. else ! youngmodulus is not allocated. obj%leaf(i)%BoundaryDisplacement = zeros(obj%leaf(i)%femdomain%nn(), 3) obj%leaf(i)%BoundaryDisplacement = defval end if end if end do !!$OMP end parallel do end if ! same for root if (allocated(obj%root)) then print *, "[ok] setPropertiesBoundaryDisplacementSoybean >> roots exist." ! leaf exists !!$OMP parallel do private(i) do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else ! allocate youngmoludus if root(i) exists and not allocated ! the default value is defval if (allocated(obj%root(i)%BoundaryDisplacement)) then print *, "[ok] setPropertiesBoundaryDisplacementSoybean & & >> root("//str(i)//")%BoundaryDisplacement >> allocated" ! then ok. let's return obj%property_deform_boundary_displacement = .true. else ! youngmodulus is not allocated. obj%root(i)%BoundaryDisplacement = zeros(obj%root(i)%femdomain%nn(), 3) obj%root(i)%BoundaryDisplacement = defval end if end if end do !!$OMP end parallel do end if obj%property_deform_boundary_Displacement = .true. end subroutine ! ################################################################## subroutine setPropertiesGravitySoybean(obj, default_value, xrange, yrange, zrange) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: default_value, xrange(2), yrange(2), zrange(2) real(real64) :: defval integer(int32) :: i, j defval = input(default=9.810d0, option=default_value) obj%Gravity_acceralation = defval obj%property_deform_gravity = .true. end subroutine ! ################################################################## subroutine setPropertiesSoybean(obj, density, YoungModulus, PoissonRatio, & InitialStress, InitialDisplacement, & BoundaryTractionForce, BoundaryDisplacement, Gravity, xr, yr, zr, & default_value) class(Soybean_), intent(inout) :: obj logical, optional, intent(in) :: density, YoungModulus, PoissonRatio, InitialStress, & InitialDisplacement, & BoundaryTractionForce, BoundaryDisplacement, Gravity real(real64), optional, intent(in) :: xr(2), yr(2), zr(2), default_value integer(int32) :: i, j ! set each conditions if (present(density)) then if (density) then call obj%setPropertiesDensity() end if end if if (present(YoungModulus)) then if (YoungModulus) then call obj%setPropertiesYoungModulus(default_value=default_value) end if end if if (present(PoissonRatio)) then if (PoissonRatio) then call obj%setPropertiesPoissonRatio(default_value=default_value) end if end if if (present(InitialDisplacement)) then if (InitialDisplacement) then call obj%setPropertiesInitialDisplacement(default_value=default_value) end if end if if (present(InitialStress)) then if (InitialStress) then call obj%setPropertiesInitialStress(default_value=default_value) end if end if if (present(BoundaryTractionForce)) then if (BoundaryTractionForce) then call obj%setPropertiesBoundaryTractionForce(default_value=default_value) end if end if if (present(BoundaryDisplacement)) then if (BoundaryDisplacement) then call obj%setPropertiesBoundaryDisplacement(default_value=default_value) end if end if if (present(Gravity)) then if (Gravity) then call obj%setPropertiesGravity(default_value=default_value) end if end if end subroutine ! ################################################################## function readyForSoybean(obj, Simulator) result(ready) class(Soybean_), intent(inout) :: obj integer(int32), intent(in) :: Simulator logical :: ready ! default = ready! ! if all the properties are set, then ready = true if (Simulator == PF_DEFORMATION_ANALYSIS) then ready = .true. ready = ready .and. obj%property_deform_material_density ready = ready .and. obj%property_deform_material_YoungModulus ready = ready .and. obj%property_deform_material_PoissonRatio ready = ready .and. obj%property_deform_initial_Displacement ready = ready .and. obj%property_deform_material_CarbonDiffusionCoefficient ready = ready .and. obj%property_deform_initial_Stress ready = ready .and. obj%property_deform_boundary_TractionForce ready = ready .and. obj%property_deform_boundary_Displacement ready = ready .and. obj%property_deform_gravity else print *, "[ERROR] readyForSoybean >> invalid Simulator type.", Simulator end if end function ! ################################################################## subroutine runSimulationSoybean(obj, Simulator, error_tolerance, debug, z_min) class(Soybean_), target, intent(inout) :: obj type(ContactMechanics_) :: contact type(FEMDomainp_), allocatable :: femdomainp(:) type(FEMDomain_), allocatable :: femdomains(:) type(Dictionary_) :: YoungModulusList type(Dictionary_) :: PoissonRatioList type(Dictionary_) :: DensityList real(real64), optional, intent(in) :: error_tolerance real(real64), intent(in) :: z_min logical, optional, intent(in) :: debug integer(int32), allocatable :: contactlist(:, :) integer(int32), intent(in) :: Simulator integer(int32) :: i, j, k, i_offset, j_offset type(IO_) :: f if (.not. obj%readyFor(Simulator)) then call obj%checkProperties(Simulator=Simulator) print *, "[ERROR] :: runSimulationSoybean >> .not.obj%readyFor(Simulator) " return end if if (Simulator == PF_DEFORMATION_ANALYSIS) then ! run print *, "[ok] Running PF_DEFORMATION_ANALYSIS..." ! 全てのdomainのpointer allocate (femdomainp(obj%numleaf() + obj%numStem() + obj%numRoot())) allocate (femdomains(obj%numleaf() + obj%numStem() + obj%numRoot())) k = 0 do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else k = k + 1 femdomainp(k)%femdomainp => obj%stem(i)%femdomain femdomains(k) = obj%stem(i)%femdomain end if end do do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else k = k + 1 femdomainp(k)%femdomainp => obj%leaf(i)%femdomain femdomains(k) = obj%leaf(i)%femdomain end if end do do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else k = k + 1 femdomainp(k)%femdomainp => obj%root(i)%femdomain femdomains(k) = obj%root(i)%femdomain end if end do ! >>>>>>>>>>>>>>>>>>>>>>> ! connectivitylist ! >>>>>>>>>>>>>>>>>>>>>>> k = obj%numStem() + obj%numleaf() + obj%numRoot() contactlist = zeros(k, k) ! leaf to stem i_offset = obj%numStem() j_offset = 0 !!!$OMP parallel do private(i,j) do i = 1, obj%numleaf() do j = 1, obj%numstem() if (obj%leaf2stem(i, j) /= 0) then contactlist(i + i_offset, j + j_offset) = obj%leaf2stem(i, j) end if end do end do !!!$OMP end parallel do ! stem to stem i_offset = 0 j_offset = 0 !!!$OMP parallel do private(i,j) do i = 1, obj%numstem() do j = 1, obj%numstem() if (obj%stem2stem(i, j) /= 0) then contactlist(i + i_offset, j + j_offset) = obj%stem2stem(i, j) end if end do end do !!!$OMP end parallel do ! root to stem i_offset = obj%numstem() + obj%numleaf() j_offset = 0 !!!$OMP parallel do private(i,j) do i = 1, obj%numroot() do j = 1, obj%numstem() if (obj%root2stem(i, j) /= 0) then contactlist(i + i_offset, j + j_offset) = obj%root2stem(i, j) end if end do end do !!!$OMP end parallel do ! root to root i_offset = obj%numstem() + obj%numroot() j_offset = obj%numstem() + obj%numroot() !!!$OMP parallel do private(i,j) do i = 1, obj%numroot() do j = 1, obj%numroot() if (obj%root2root(i, j) /= 0) then contactlist(i + i_offset, j + j_offset) = obj%root2root(i, j) end if end do end do !!!$OMP end parallel do ! YoungModulusListを作る allocate (YoungModulusList%pages(obj%numleaf() + obj%numStem() + obj%numRoot())) k = 0 do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else k = k + 1 YoungModulusList%pages(k)%realist = obj%stem(i)%YoungModulus end if end do do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else k = k + 1 YoungModulusList%pages(k)%realist = obj%leaf(i)%YoungModulus end if end do do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else k = k + 1 YoungModulusList%pages(k)%realist = obj%root(i)%YoungModulus end if end do ! PoissonRatioListを作る allocate (PoissonRatioList%pages(obj%numstem() + obj%numleaf() + obj%numRoot())) k = 0 do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else k = k + 1 PoissonRatioList%pages(k)%realist = obj%stem(i)%PoissonRatio end if end do do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else k = k + 1 PoissonRatioList%pages(k)%realist = obj%leaf(i)%PoissonRatio end if end do do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else k = k + 1 PoissonRatioList%pages(k)%realist = obj%root(i)%PoissonRatio end if end do ! DensityListを作る allocate (DensityList%pages(obj%numStem() + obj%numLeaf() + obj%numRoot())) k = 0 do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else k = k + 1 DensityList%pages(k)%realist = obj%stem(i)%Density end if end do do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else k = k + 1 DensityList%pages(k)%realist = obj%leaf(i)%Density end if end do do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else k = k + 1 DensityList%pages(k)%realist = obj%root(i)%Density end if end do ! ContactMechanicsClassを呼ぶ call contact%init(femdomains=femdomains, contactlist=contactlist) print *, "[ok] Initialized simulator" ! 要修正(1) 材料パラメータをElement-wiseに導入する． ! Import material parameters ! Element-wise にする． contact%YoungModulusList = YoungModulusList contact%PoissonRatioList = PoissonRatioList contact%DensityList = DensityList contact%gravity = obj%Gravity_acceralation ! call contact%setup(penaltyparameter=obj%PenaltyParameter, & GaussPointProjection=obj%GaussPointProjection) ! 要修正(2) 境界条件を課す節点のリスト+値から境界条件を導入． ! Boundary conditions ! fix displacement ! Listから選択 print *, "[ok] set up done." call contact%fix(direction="x", disp=0.0d0, DomainID=1, z_max=0.010d0) call contact%fix(direction="y", disp=0.0d0, DomainID=1, z_max=0.010d0) call contact%fix(direction="z", disp=0.0d0, DomainID=1, z_max=0.010d0) !do i=1,size(contact%femdomains) call contact%fix(direction="x", disp=-0.01d0, DomainID=5, z_min=0.30d0, z_max=0.410d0) !enddo ! traction forceを入れる． ! solve > get displacement !call f%open("debug.txt") !call f%write(contact%contactlist) !call f%close() !stop contact%solver%er0 = input(default=dble(1.0e-7), option=error_tolerance) if (present(debug)) then contact%solver%debug = debug end if call contact%solver%solve("BiCGSTAB") ! update mesh call contact%updateMesh() k = 0 do i = 1, size(obj%stem) if (obj%stem(i)%empty()) then cycle else k = k + 1 obj%stem(i)%femdomain = femdomains(k) end if end do do i = 1, size(obj%leaf) if (obj%leaf(i)%empty()) then cycle else k = k + 1 obj%leaf(i)%femdomain = femdomains(k) end if end do do i = 1, size(obj%root) if (obj%root(i)%empty()) then cycle else k = k + 1 obj%root(i)%femdomain = femdomains(k) end if end do ! 要修正(3) 変位から応力，等価節点力を計算 else print *, "[ERROR] readyForSoybean >> invalid Simulator type.", Simulator end if end subroutine ! ################################################################## pure function getPointsSoybean(obj, leaf, stem, root) result(points) class(Soybean_), intent(in) :: obj logical, optional, intent(in) :: leaf, stem, root real(real64), allocatable :: points(:, :), buf(:, :) logical :: count_leaf, count_stem, count_root integer(int32) :: i, n, id if (present(leaf)) then count_leaf = Leaf end if if (present(stem)) then count_stem = Stem end if if (present(root)) then count_root = Root end if n = obj%nn() points = zeros(n, 3) id = 1 !if(count_stem)then if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then points(id:id + obj%stem(i)%femdomain%nn() - 1, 1:3) = & obj%stem(i)%femdomain%mesh%nodcoord(1:obj%stem(i)%femdomain%nn(), 1:3) id = id + obj%stem(i)%femdomain%nn() end if end do end if !endif !if(count_leaf)then if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then points(id:id + obj%leaf(i)%femdomain%nn() - 1, 1:3) = & obj%leaf(i)%femdomain%mesh%nodcoord(:, :) id = id + obj%leaf(i)%femdomain%nn() end if end do end if !endif !if(count_root)then if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%empty()) then points(id:id + obj%root(i)%femdomain%nn() - 1, 1:3) = & obj%root(i)%femdomain%mesh%nodcoord(:, :) id = id + obj%root(i)%femdomain%nn() end if end do end if !endif !if(id /=n)then ! buf = points ! points = zeros(id,3) ! points(1:id,:) = buf(1:id,:) !endif end function ! ############################################################################ ! ################################################################## subroutine setPointsSoybean(obj, points) class(Soybean_), intent(inout) :: obj real(real64), intent(in) :: points(:, :) integer(int32) :: i, n, id if (size(points, 1) /= obj%nn()) then print *, "[ERROR] setPointsSoybean >> Invalid size of arg points" print *, "size(points,1)/=obj%nn()", size(points, 1), obj%nn() return end if id = 1 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then obj%stem(i)%femdomain%mesh%nodcoord(1:obj%stem(i)%femdomain%nn(), 1:3) & = points(id:id + obj%stem(i)%femdomain%nn() - 1, 1:3) id = id + obj%stem(i)%femdomain%nn() end if end do end if if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then obj%leaf(i)%femdomain%mesh%nodcoord(:, :) & = points(id:id + obj%leaf(i)%femdomain%nn() - 1, 1:3) id = id + obj%leaf(i)%femdomain%nn() end if end do end if if (allocated(obj%root)) then do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%empty()) then obj%root(i)%femdomain%mesh%nodcoord(:, :) & = points(id:id + obj%root(i)%femdomain%nn() - 1, 1:3) id = id + obj%root(i)%femdomain%nn() end if end do end if end subroutine ! ############################################################################ function getDistanceFromGroundSoybean(obj) result(distance_per_nodes) class(Soybean_), intent(inout) :: obj real(real64), allocatable :: distance_per_nodes(:), xA(:), xB(:), dist_per_stem(:), & dist_per_root(:) integer(int32), allocatable :: num_of_point(:) real(real64) :: dist_AB, dist_add, dist_parent integer(int32) :: i, j, k, node_id, num_node, id, from_id, to_id, stem_id ! get distance from the intersection between root and stem node_id = 1 ! get the intersection num_node = obj%nn() distance_per_nodes = zeros(obj%nn()) dist_per_stem = zeros(size(obj%stem)) dist_per_root = zeros(size(obj%root)) num_of_point = obj%getNumberOfPoint() id = 0 ! global search ! calculate distance from bottom to "A" node of each stem domains ! 1節目から順番に接いでいったと仮定する． !!$OMP parallel do private(i) do i = 1, size(obj%stem) if (.not. obj%stem(i)%empty()) then dist_per_stem(i) = obj%getDistanceToGroundFromStemID( & dist_in=0.0d0, & stem_id=i) end if end do !!$OMP end parallel do ! comupte node-wise data from stem-wise data do i = 1, size(num_of_point) if (i == 1) then from_id = 1 to_id = num_of_point(1) else from_id = sum(num_of_point(1:i - 1)) + 1 to_id = sum(num_of_point(1:i)) end if distance_per_nodes(from_id:to_id) = & distance_per_nodes(from_id:to_id) & + dist_per_stem(i) end do do i = obj%numStem() + 1, obj%numStem() + obj%numLeaf() if (i == 1) then from_id = 1 to_id = num_of_point(1) else from_id = sum(num_of_point(1:i - 1)) + 1 to_id = sum(num_of_point(1:i)) end if do j = 1, size(obj%leaf2stem, 1) if (obj%leaf2stem(i - obj%numStem(), j) /= 0) then stem_id = j exit end if end do distance_per_nodes(from_id:to_id) = & distance_per_nodes(from_id:to_id) & + dist_per_stem(stem_id) end do ! 1節目から順番に接いでいったと仮定する． !!$OMP parallel do private(i) do i = 1, size(obj%Root) if (.not. obj%Root(i)%empty()) then dist_per_Root(i) = obj%getDistanceToGroundFromRootID( & dist_in=0.0d0, & Root_id=i) end if end do !!$OMP end parallel do ! comupte node-wise data from root-wise data do i = obj%numstem() + obj%numleaf() + 1, obj%numstem() + obj%numleaf() + obj%numRoot() if (i == 1) then from_id = 1 to_id = num_of_point(1) else from_id = sum(num_of_point(1:i - 1)) + 1 to_id = sum(num_of_point(1:i)) end if distance_per_nodes(from_id:to_id) = & distance_per_nodes(from_id:to_id) & + dist_per_root(i - obj%numstem() - obj%numleaf()) end do ! node-to-node ! @stem id = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then id = id + 1 do j = 1, obj%stem(i)%femdomain%nn() xA = obj%stem(i)%getCoordinate("A") xB = obj%stem(i)%femdomain%mesh%nodcoord(j, :) if (id == 1 .and. i == 1) then node_id = j else node_id = sum(num_of_point(1:id)) + j end if distance_per_nodes(node_id) = distance_per_nodes(node_id) & + norm(xA - xB) end do end if end do ! for each domain ! @leaf id = obj%numStem() - 1 do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then id = id + 1 do j = 1, obj%leaf(i)%femdomain%nn() xA = obj%leaf(i)%getCoordinate("A") xB = obj%leaf(i)%femdomain%mesh%nodcoord(j, :) if (id == 1 .and. i == 1) then node_id = j else node_id = sum(num_of_point(1:id)) + j end if distance_per_nodes(node_id) = distance_per_nodes(node_id) & + norm(xA - xB) end do end if end do ! for each domain ! @root id = obj%numStem() + obj%numLeaf() - 1 do i = 1, size(obj%root) if (.not. obj%root(i)%femdomain%empty()) then id = id + 1 do j = 1, obj%root(i)%femdomain%nn() xA = obj%root(i)%getCoordinate("A") xB = obj%root(i)%femdomain%mesh%nodcoord(j, :) if (id == 1 .and. i == 1) then node_id = j else node_id = sum(num_of_point(1:id)) + j end if distance_per_nodes(node_id) = distance_per_nodes(node_id) & + norm(xA - xB) end do end if end do end function ! ############################################################################ ! ############################################################################ function getNumberOfPointSoybean(obj) result(NumberOfPoint) class(Soybean_), intent(in) :: obj integer(int32), allocatable :: NumberOfPoint(:) integer(int32) :: i, id ! order :: stem -> leaf -> root NumberOfPoint = zeros(obj%numStem() + obj%numLeaf() + obj%numRoot()) id = 1 do i = 1, size(obj%stem) if (.not. obj%stem(i)%empty()) then NumberOfPoint(id) = obj%stem(i)%femdomain%nn() id = id + 1 end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%empty()) then NumberOfPoint(id) = obj%leaf(i)%femdomain%nn() id = id + 1 end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%empty()) then NumberOfPoint(id) = obj%root(i)%femdomain%nn() id = id + 1 end if end do end function ! ############################################################################ ! ############################################################################ function getNumberOfElementSoybean(obj) result(NumberOfElement) class(Soybean_), intent(in) :: obj integer(int32), allocatable :: NumberOfElement(:) integer(int32) :: i, id ! order :: stem -> leaf -> root NumberOfElement = zeros(obj%numStem() + obj%numLeaf() + obj%numRoot()) id = 1 do i = 1, size(obj%stem) if (.not. obj%stem(i)%empty()) then NumberOfElement(id) = obj%stem(i)%femdomain%ne() id = id + 1 end if end do do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%empty()) then NumberOfElement(id) = obj%leaf(i)%femdomain%ne() id = id + 1 end if end do do i = 1, size(obj%root) if (.not. obj%root(i)%empty()) then NumberOfElement(id) = obj%root(i)%femdomain%ne() id = id + 1 end if end do end function ! ############################################################################ ! ############################################################################ recursive function getDistanceToGroundFromStemIDSoybean(obj, dist_in, stem_id) result(dist_ground) class(Soybean_), intent(in) :: obj real(real64), intent(in) :: dist_in integer(int32), intent(in) :: stem_id integer(int32) :: j, parent_id real(real64) :: dist_ground real(real64) :: dist_AB, dist_old real(real64), allocatable :: xA(:), xB(:) ! check stem-to-stem connectivity dist_ground = dist_in if (maxval(obj%stem2stem(stem_id, :)) /= 1) then return end if do j = 1, size(obj%stem2stem, 1) if (obj%stem2stem(stem_id, j) == 1) then if (.not. obj%stem(j)%femdomain%empty()) then ! found parent ! number of parent node should be 1 parent_id = j xA = obj%stem(parent_id)%getCoordinate("A") xB = obj%stem(parent_id)%getCoordinate("B") dist_AB = sqrt(dot_product(xA - xB, xA - xB)) dist_old = dist_in + dist_AB dist_ground = obj%getDistanceToGroundFromStemID( & dist_in=dist_old, & stem_id=parent_id) return end if end if end do end function ! ############################################################################ ! ############################################################################ recursive function getDistanceToGroundFromRootIDSoybean(obj, dist_in, root_id) result(dist_ground) class(Soybean_), intent(in) :: obj real(real64), intent(in) :: dist_in integer(int32), intent(in) :: root_id integer(int32) :: j, parent_id real(real64) :: dist_ground real(real64) :: dist_AB, dist_old real(real64), allocatable :: xA(:), xB(:) ! check root-to-root connectivity dist_ground = dist_in if (maxval(obj%root2root(root_id, :)) /= 1) then return end if do j = 1, size(obj%root2root, 1) if (obj%root2root(root_id, j) == 1) then if (.not. obj%root(j)%femdomain%empty()) then ! found parent ! number of parent node should be 1 parent_id = j xA = obj%root(parent_id)%getCoordinate("A") xB = obj%root(parent_id)%getCoordinate("B") dist_AB = sqrt(dot_product(xA - xB, xA - xB)) dist_old = dist_in + dist_AB dist_ground = obj%getDistanceToGroundFromrootID( & dist_in=dist_old, & root_id=parent_id) return end if end if end do end function ! ############################################################################ ! ############################################################################ function getRangeOfNodeIDSoybean(obj, stem, leaf, root) result(id_range) class(Soybean_), intent(in) :: obj integer(int32) :: id_range(2), numStemNode, numLeafNode, numRootNode, i logical, optional, intent(in) :: stem, leaf, root id_range(1:2) = [0, 0] numStemNode = 0 do i = 1, size(obj%stem) if (.not. obj%stem(i)%femdomain%empty()) then numStemNode = numStemNode + obj%stem(i)%femdomain%nn() end if end do if (present(stem)) then if (stem) then id_range(1) = 1 id_range(2) = numStemNode return end if end if numLeafNode = 0 do i = 1, size(obj%Leaf) if (.not. obj%Leaf(i)%femdomain%empty()) then numLeafNode = numLeafNode + obj%Leaf(i)%femdomain%nn() end if end do if (present(leaf)) then if (leaf) then id_range = [numStemNode + 1, numStemNode + numLeafNode] return end if end if numRootNode = 0 do i = 1, size(obj%Root) if (.not. obj%Root(i)%femdomain%empty()) then numRootNode = numRootNode + obj%Root(i)%femdomain%nn() end if end do if (present(root)) then if (root) then id_range = [numStemNode + numLeafNode + 1, & numStemNode + numLeafNode + numRootNode] return end if end if end function ! ############################################################################ ! ############################################################################ function getSpectrumSoybean(obj, light, Transparency, Resolution, num_threads, leaf) result(spectrum) class(Soybean_), intent(inout) :: obj type(Light_), intent(in) :: light real(real64), optional, intent(in) :: Transparency, Resolution integer(int32), optional, intent(in) :: num_threads ! leaf of other plants type(Leaf_), optional, intent(inout) :: leaf(:) real(real64), allocatable :: ppfd(:), tp_ratio(:), spectrum(:, :) integeR(int32) :: i ppfd = obj%getPPFD(light, Transparency, Resolution, num_threads, leaf) tp_ratio = ppfd/light%maxPPFD spectrum = zeros(size(ppfd), size(light%spectrum)) ! 400-700nmはtransparencyに基づき減衰 ! 1-399nm, 701nm以上はそのまま透過 do i = 1, size(ppfd) spectrum(i, :) = light%spectrum(:) spectrum(i, 400:700) = light%spectrum(400:700)*tp_ratio(i) end do end function ! ############################################################################ ! ############################################################################ function getPPFDSoybean(obj, light, Transparency, Resolution, num_threads, leaf) result(ppfd) class(Soybean_), intent(inout) :: obj type(Light_), intent(in) :: light real(real64), optional, intent(in) :: Transparency, Resolution integer(int32), optional, intent(in) :: num_threads ! leaf of other plants type(Leaf_), optional, intent(inout) :: leaf(:) real(real64), allocatable :: ppfd(:), NumberOfElement(:), NumberOfPoint(:) real(real64), allocatable :: nodcoord(:, :), radius_vec(:), elem_cosins(:) integer(int32), allocatable :: leaf_pass_num(:) real(real64) ::thickness, center_x(3), xmin(3), xmax(3), radius, radius_tr, coord(3), Transparency_val real(real64) :: zmin integer(int32) :: from, to, i, n, j, k, l, element_id logical :: inside, upside ! compute cosin !elem_cosins = obj%getLeafCosValue(light) ! rotate soybean call obj%rotate(z=radian(180.0d0 - light%angles(1))) call obj%rotate(x=radian(90.0d0 - light%angles(2))) if (present(leaf)) then do i = 1, size(leaf) call leaf(i)%femdomain%rotate(z=radian(180.0d0 - light%angles(1))) call leaf(i)%femdomain%rotate(x=radian(90.0d0 - light%angles(2))) end do end if !本当にあってる？？ ! after this, rotate this back again radius = input(default=0.0050d0, option=Resolution) Transparency_val = input(default=0.30d0, option=Transparency) ! ppfdが通過した葉の積算長さで減衰するモデル NumberOfElement = obj%getNumberOfElement() ppfd = zeros(obj%ne()) elem_cosins = zeros(obj%ne()) !i = sum(NumberOfElement(1:obj%numStem())+1) i = sum(NumberOfElement(1:obj%numStem())) + 1 j = sum(NumberOfElement(1:obj%numStem() + obj%numLeaf())) ppfd(i:j) = light%maxPPFD leaf_pass_num = int(zeros(obj%ne())) n = sum(NumberOfElement(1:obj%numStem())) from = n if (present(num_threads)) then call omp_set_num_threads(num_threads) end if ! leaf of other plants if (present(leaf)) then !$OMP parallel do default(shared), private(j,k,inside,upside,center_x,radius_vec,radius_tr,zmin,n,element_id) do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then !print *, i, "/", obj%numLeaf() !$OMP parallel do default(shared), private(k,inside,upside,center_x,radius_vec,radius_tr,zmin,n,element_id) do j = 1, obj%leaf(i)%femdomain%ne() ! 中心座標 center_x = obj%leaf(i)%femdomain%centerPosition(ElementID=j) ! 枚数のみカウント ! 1枚あたりthicknessだけ距離加算 !$OMP parallel do default(shared), private(inside,upside,radius_vec,radius_tr,zmin,n,element_id) do k = 1, size(leaf) if (.not. leaf(k)%femdomain%empty()) then inside = .false. radius_vec = zeros(leaf(k)%femdomain%nn()) radius_vec = (leaf(k)%femdomain%mesh%nodcoord(:, 1) - center_x(1))**2 & + (leaf(k)%femdomain%mesh%nodcoord(:, 2) - center_x(2))**2 radius_tr = minval(radius_vec) if (radius_tr < radius*radius) then zmin = leaf(k)%femdomain%mesh%nodcoord(minvalID(radius_vec), 3) inside = .true. end if !あるいは，zmin,xmax,ymin,ymaxの正負で場合分けできるのでは？ !>>なぜか失敗 !upside = (center_x(3) < zmin ) if (inside .eqv. .true.) then if (center_x(3) <= zmin) then !print *, center_x(3) , zmin n = obj%numStem() + (i - 1) element_id = sum(NumberOfElement(1:n)) + j leaf_pass_num(element_id) = leaf_pass_num(element_id) + 1 end if end if end if end do !$OMP end parallel do end do !$OMP end parallel do end if end do !$OMP end parallel do end if !$OMP parallel private(j,k,inside,upside,center_x,radius_vec,radius_tr,zmin,n,element_id) !$OMP do reduction(+:leaf_pass_num) do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%empty()) then cycle else !print *, i, "/", obj%numLeaf() !!$OMP parallel do default(shared), private(k,inside,upside,center_x,radius_vec,radius_tr,zmin,n,element_id) do j = 1, obj%leaf(i)%femdomain%ne() ! 中心座標 center_x = obj%leaf(i)%femdomain%centerPosition(ElementID=j) ! 枚数のみカウント ! 1枚あたりthicknessだけ距離加算 !!$OMP parallel do default(shared), private(inside,upside,radius_vec,radius_tr,zmin,n,element_id) do k = 1, size(obj%leaf) if (i == k) cycle if (obj%leaf(k)%femdomain%empty()) then cycle else inside = .false. radius_vec = zeros(obj%leaf(k)%femdomain%nn()) radius_vec = (obj%leaf(k)%femdomain%mesh%nodcoord(:, 1) - center_x(1))**2 & + (obj%leaf(k)%femdomain%mesh%nodcoord(:, 2) - center_x(2))**2 radius_tr = minval(radius_vec) if (radius_tr < radius*radius) then zmin = obj%leaf(k)%femdomain%mesh%nodcoord(minvalID(radius_vec), 3) inside = .true. end if !あるいは，zmin,xmax,ymin,ymaxの正負で場合分けできるのでは？ !>>なぜか失敗 if (inside .eqv. .true.) then if (center_x(3) <= zmin) then if (inside .eqv. .false.) then cycle end if if (center_x(3) > zmin) then cycle end if n = obj%numStem() + (i - 1) element_id = sum(NumberOfElement(1:n)) + j leaf_pass_num(element_id) = leaf_pass_num(element_id) + 1 end if end if end if end do !!$OMP end parallel do end do !!$OMP end parallel do end if end do !$OMP end do !$OMP end parallel !ppfd = ppfd*reduction*cosin-value do i = 1, obj%ne() ! 400-700を一律減衰 ppfd(i) = ppfd(i)*Transparency_val**leaf_pass_num(i) end do !ppfd(:) = ppfd(:)*elem_cosins(:) ! get back call obj%rotate(x=-radian(90.0d0 - light%angles(2))) call obj%rotate(z=-radian(180.0d0 - light%angles(1))) if (present(leaf)) then do i = 1, size(leaf) call leaf(i)%femdomain%rotate(x=-radian(90.0d0 - light%angles(2))) call leaf(i)%femdomain%rotate(z=-radian(180.0d0 - light%angles(1))) end do end if end function ! ############################################################################ ! ############################################################################ function getLeafCosValueSoybean(obj, light, num_threads) result(elem_cosins) class(Soybean_), intent(inout) :: obj type(Light_), intent(in) :: light integer(int32), optional, intent(in) :: num_threads real(real64), allocatable :: cosin_value(:), NumberOfElement(:), NumberOfPoint(:) real(real64), allocatable :: leaf_pass_num(:), nodcoord(:, :), radius_vec(:), elem_cosins(:), & N_Light(:), N_Leaf(:) real(real64) ::thickness, center_x(3), xmin(3), xmax(3), radius, radius_tr, coord(3), Transparency_val real(real64) :: zmin integer(int32) :: from, to, i, n, j, k, l, element_id logical :: inside, upside ! rotate soybean call obj%rotate(z=radian(180.0d0 - light%angles(1))) call obj%rotate(x=radian(90.0d0 - light%angles(2))) NumberOfElement = obj%getNumberOfElement() elem_cosins = zeros(obj%ne()) if (present(num_threads)) then call omp_set_num_threads(num_threads) end if !$OMP parallel do default(shared), private(j,k,n,element_id,N_leaf,N_light) do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then !print *, i, "/", obj%numLeaf() !$OMP parallel do default(shared), private(k,n,element_id,N_leaf,N_light) do j = 1, obj%leaf(i)%femdomain%ne() ! cosin rule n = obj%numStem() + (i - 1) element_id = sum(NumberOfElement(1:n)) + j N_leaf = obj%leaf(i)%getNormalVector(ElementID=j) N_light = [0.0d0, 0.0d0, 1.0d0] elem_cosins(element_id) = dble(dot_product(N_light, N_Leaf)) end do !$OMP end parallel do end if end do !$OMP end parallel do ! get back call obj%rotate(x=-radian(90.0d0 - light%angles(2))) call obj%rotate(z=-radian(180.0d0 - light%angles(1))) end function ! ############################################################################ function getPhotoSynthesisSoybean(obj, light, air, dt, Transparency, Resolution, ppfd) result(photosynthesis) class(Soybean_), intent(inout) :: obj type(Light_), intent(in) :: light type(Air_), intent(in) :: Air real(real64), intent(in) :: dt real(real64), optional, intent(in) :: Transparency, Resolution, ppfd(:) real(real64), allocatable :: photosynthesis(:) integer(int32), allocatable :: NumberOfElement(:) integer(int32) :: i, j, offset, elem_id if (.not. allocated(obj%Photosynthate_n)) then obj%Photosynthate_n = zeros(obj%nn()) end if photosynthesis = zeros(obj%ne()) NumberOfElement = obj%getNumberOfElement() offset = sum(NumberOfElement(1:obj%numStem())) ! before photosynthesis elem_id = offset do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() elem_id = elem_id + 1 photosynthesis(elem_id) = obj%leaf(i)%source(j) end do end if end do if (.not. present(ppfd)) then call obj%laytracing(light=light, Transparency=Transparency, Resolution=Resolution) ! 光合成量を計算 do i = 1, size(obj%Leaf) if (obj%Leaf(i)%femdomain%mesh%empty() .eqv. .false.) then call obj%leaf(i)%photosynthesis(dt=dt, air=air) end if end do else elem_id = offset do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() elem_id = elem_id + 1 obj%leaf(i)%ppfd(j) = ppfd(elem_id) !- photosynthesis(elem_id) end do end if end do end if elem_id = offset do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() elem_id = elem_id + 1 photosynthesis(elem_id) = obj%leaf(i)%source(j) - photosynthesis(elem_id) end do end if end do end function ! ############################################################################ function getPhotoSynthesis_by_env_soybean(this, env, dt, Transparency, soybean_canopy) result(elem_photosynthesis) class(Soybean_), intent(inout) :: this class(Environment_), intent(in):: env real(real64), intent(in) :: dt ! sec. type(Soybean_), optional, intent(inout) :: soybean_canopy(:) type(Leaf_), allocatable :: leaf(:) real(real64), optional, intent(in) :: Transparency real(real64), allocatable :: elem_ppfd(:), elem_volume(:), & elem_photospeed(:), elem_photosynthesis(:) if (.not. allocated(this%Photosynthate_n)) then this%Photosynthate_n = zeros(this%nn()) end if elem_volume = this%getVolumePerElement() if (present(soybean_canopy)) then leaf = this%getIntersectLeaf(soybeans=soybean_canopy) elem_ppfd = this%getPPFD( & Light=env%Light, & Transparency=input(default=0.10d0, option=Transparency), & leaf=leaf) else elem_ppfd = this%getPPFD( & Light=env%Light, & Transparency=input(default=0.10d0, option=Transparency)) end if elem_photospeed = this%getPhotoSynthesisSpeedPerVolume( & Light=env%Light, Air=env%Air, dt=dt, & Transparency=input(default=0.10d0, option=Transparency), & ppfd=elem_ppfd) elem_photosynthesis = elem_photospeed*elem_volume end function ! ############################################################################ function getPhotoSynthesisSpeedPerVolumeSoybean(obj, light, air, dt, Transparency, Resolution, ppfd) result(photosynthesis) class(Soybean_), intent(inout) :: obj type(Light_), intent(in) :: light type(Air_), intent(in) :: Air real(real64), intent(in) :: dt real(real64), optional, intent(in) :: Transparency, Resolution, ppfd(:) real(real64), allocatable :: photosynthesis(:), Speed_PV(:) integer(int32), allocatable :: NumberOfElement(:) integer(int32) :: i, j, offset, elem_id if (.not. allocated(obj%Photosynthate_n)) then obj%Photosynthate_n = zeros(obj%nn()) end if photosynthesis = zeros(obj%ne()) NumberOfElement = obj%getNumberOfElement() offset = sum(NumberOfElement(1:obj%numStem())) if (.not. present(ppfd)) then call obj%laytracing(light=light, Transparency=Transparency, Resolution=Resolution) else elem_id = offset do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then do j = 1, obj%leaf(i)%femdomain%ne() elem_id = elem_id + 1 obj%leaf(i)%ppfd(j) = ppfd(elem_id) !- photosynthesis(elem_id) end do end if end do end if elem_id = offset do i = 1, size(obj%leaf) if (.not. obj%leaf(i)%femdomain%empty()) then Speed_PV = obj%leaf(i)%getPhotoSynthesisSpeedPerVolume(dt=dt, air=air) do j = 1, obj%leaf(i)%femdomain%ne() elem_id = elem_id + 1 photosynthesis(elem_id) = Speed_PV(j) end do end if end do end function ! ############################################################################ subroutine fixReversedElementsSoybean(obj) class(Soybean_), intent(inout) :: obj integer(int32) :: i, j real(Real64) :: v do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%empty()) cycle do j = 1, obj%stem(i)%femdomain%ne() v = obj%stem(i)%femdomain%getvolume(elem=j) if (v <= 0) then call obj%stem(i)%femdomain%fixReversedElements() if (obj%stem(i)%femdomain%getvolume(elem=j) < 0.0d0) then print *, "[ERROR] >> fixReversedElementsSoybean >> not fixed" stop end if exit end if end do end do do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%empty()) cycle do j = 1, obj%Leaf(i)%femdomain%ne() v = obj%Leaf(i)%femdomain%getvolume(elem=j) if (v <= 0) then call obj%Leaf(i)%femdomain%fixReversedElements() if (obj%Leaf(i)%femdomain%getvolume(elem=j) < 0.0d0) then print *, "[ERROR] >> fixReversedElementsSoybean >> not fixed" stop end if exit end if end do end do do i = 1, size(obj%root) if (obj%root(i)%femdomain%empty()) cycle do j = 1, obj%root(i)%femdomain%ne() v = obj%root(i)%femdomain%getvolume(elem=j) if (v <= 0) then call obj%root(i)%femdomain%fixReversedElements() if (obj%root(i)%femdomain%getvolume(elem=j) < 0.0d0) then print *, "[ERROR] >> fixReversedElementsSoybean >> not fixed" stop end if exit end if end do end do end subroutine ! ################################################################ function convertDataFormatSoybean(obj, scalar, new_format) result(ret) class(Soybean_), intent(in) :: obj real(real64), intent(in) :: scalar(:) integer(int32), intent(in) :: new_format real(real64), allocatable :: ret(:) integer(int32), allocatable :: NumberOfElement(:), NumberOfPoint(:) integer(int32) :: i, k, j, n logical :: ELEMENT_WISE, POINT_WISE NumberOfPoint = obj%getNumberOfPoint() NumberOfElement = obj%getNumberOfElement() POINT_WISE = .false. ELEMENT_WISE = .false. if (sum(NumberOfPoint) == size(scalar)) then POINT_WISE = .true. elseif (sum(NumberOfElement) == size(scalar)) then ELEMENT_WISE = .true. else print *, "[ERROR] convertDataFormatSoybean >> " print *, "Invalid vector size", size(scalar) stop end if if (new_format == PF_SOY_OBJECT_WISE) then ! for each root/stem/soil object ret = zeros(obj%numStem() + obj%numLeaf() + obj%numRoot()) if (POINT_WISE) then n = 0 k = 0 do i = 1, obj%numStem() k = k + 1 do j = 1, obj%stem(i)%femdomain%nn() n = n + 1 ret(k) = ret(k) + scalar(n) end do end do do i = 1, obj%numLeaf() k = k + 1 do j = 1, obj%Leaf(i)%femdomain%nn() n = n + 1 ret(k) = ret(k) + scalar(n) end do end do do i = 1, obj%numRoot() k = k + 1 do j = 1, obj%Root(i)%femdomain%nn() n = n + 1 ret(k) = ret(k) + scalar(n) end do end do elseif (ELEMENT_WISE) then n = 0 k = 0 do i = 1, obj%numStem() k = k + 1 do j = 1, obj%stem(i)%femdomain%ne() n = n + 1 ret(k) = ret(k) + scalar(n) end do end do do i = 1, obj%numLeaf() k = k + 1 do j = 1, obj%Leaf(i)%femdomain%ne() n = n + 1 ret(k) = ret(k) + scalar(n) end do end do do i = 1, obj%numRoot() k = k + 1 do j = 1, obj%Root(i)%femdomain%ne() n = n + 1 ret(k) = ret(k) + scalar(n) end do end do end if end if end function ! ################################################################ function getLeafAreaSoybean(obj) result(LeafArea) class(Soybean_), intent(in) :: obj real(real64) :: LeafArea integer(int32) :: i LeafArea = 0.0d0 do i = 1, obj%numLeaf() LeafArea = LeafArea + obj%leaf(i)%getLeafArea() end do end function ! ################################################################ function getIntersectLeafSoybean(obj, soybeans, light, except) result(Leaf) class(Soybean_), intent(inout) :: obj type(Soybean_), intent(inout) :: soybeans(:) type(Light_), optional, intent(in) :: light ! default is z+ direction type(Leaf_), allocatable :: leaf(:) real(real64), allocatable :: points(:, :), mypoints(:, :) integer(int32), optional, intent(in) :: except real(real64) :: obj_radius, obj_center(3) real(real64) :: chk_radius, chk_center(3), dist_2 integer(int32) :: i, j, k, num_leaf logical, allocatable :: overset(:), overset_leaf(:) ! search Intersect leaf ! considering light position if (present(light)) then call obj%rotate(z=radian(180.0d0 - light%angles(1))) call obj%rotate(x=radian(90.0d0 - light%angles(2))) if (present(except)) then do i = 1, size(soybeans) if (i == except) cycle call soybeans(i)%rotate(z=radian(180.0d0 - light%angles(1))) call soybeans(i)%rotate(x=radian(90.0d0 - light%angles(2))) end do else do i = 1, size(soybeans) call soybeans(i)%rotate(z=radian(180.0d0 - light%angles(1))) call soybeans(i)%rotate(x=radian(90.0d0 - light%angles(2))) end do end if end if obj_radius = obj%getRadius() obj_center = obj%getCenter() ! search overlaped soybeans allocate (overset(size(soybeans))) overset(:) = .false. do i = 1, size(soybeans) if (soybeans(i)%uuid == obj%uuid) cycle if (present(except)) then if (i == except) cycle end if chk_radius = soybeans(i)%getRadius() chk_Center = soybeans(i)%getCenter() dist_2 = norm(obj_center(1:2) - chk_center(1:2)) if (dist_2 <= chk_radius + obj_radius) then ! added 2022/1/29, trial points = soybeans(i)%getPoints(leaf=.true., stem=.false., root=.false.) mypoints = obj%getPoints(leaf=.true., stem=.false., root=.false.) ! if a soybean is above mysoy, count ! added 2022/1/29, trial if (minval(points(:, 3)) >= maxval(mypoints(:, 3))) then overset(i) = .true. end if else cycle end if end do ! count number of leaf num_leaf = 0 do i = 1, size(soybeans) if (present(except)) then if (i == except) cycle end if if (overset(i)) then !allocate(overset_leaf(size(soybeans(i)%leaf ) )) !overset_leaf(:) = .false. do j = 1, size(soybeans(i)%leaf) if (soybeans(i)%leaf(j)%femdomain%empty()) cycle chk_radius = soybeans(i)%leaf(j)%getRadius() chk_Center = soybeans(i)%leaf(j)%getCenter() dist_2 = norm(obj_center(1:2) - chk_center(1:2)) if (dist_2 <= chk_radius + obj_radius) then !overset_leaf(k) = .true. num_leaf = num_leaf + 1 else cycle end if end do end if end do allocate (leaf(num_leaf)) num_leaf = 0 do i = 1, size(soybeans) if (present(except)) then if (i == except) cycle end if if (overset(i)) then do j = 1, size(soybeans(i)%leaf) if (soybeans(i)%leaf(j)%femdomain%empty()) cycle chk_radius = soybeans(i)%leaf(j)%getRadius() chk_Center = soybeans(i)%leaf(j)%getCenter() dist_2 = norm(obj_center(1:2) - chk_center(1:2)) if (dist_2 <= chk_radius + obj_radius) then num_leaf = num_leaf + 1 leaf(num_leaf) = soybeans(i)%leaf(j) else cycle end if end do end if end do if (present(light)) then call obj%rotate(x=-radian(90.0d0 - light%angles(2))) call obj%rotate(z=-radian(180.0d0 - light%angles(1))) if (present(except)) then do i = 1, size(soybeans) if (i == except) cycle call soybeans(i)%rotate(x=-radian(90.0d0 - light%angles(2))) call soybeans(i)%rotate(z=-radian(180.0d0 - light%angles(1))) end do else do i = 1, size(soybeans) call soybeans(i)%rotate(x=-radian(90.0d0 - light%angles(2))) call soybeans(i)%rotate(z=-radian(180.0d0 - light%angles(1))) end do end if do i = 1, size(leaf) call leaf(i)%femdomain%rotate(x=-radian(90.0d0 - light%angles(2))) call leaf(i)%femdomain%rotate(z=-radian(180.0d0 - light%angles(1))) end do end if end function ! ################################################################ ! ################################################################ pure function getRadiusSoybean(obj) result(radius) class(Soybean_), intent(in) :: obj real(real64), allocatable :: Points(:, :) real(real64) :: radius, center(3) Points = obj%getPoints() ! search Intersect leaf center = obj%getCenter() Points(:, 1) = Points(:, 1) - center(1) Points(:, 2) = Points(:, 2) - center(2) radius = maxval(Points(:, 1)*Points(:, 1) + Points(:, 2)*Points(:, 2)) radius = sqrt(radius) end function ! ################################################################ ! ################################################################ pure function getCenterSoybean(obj) result(Center) class(Soybean_), intent(in) :: obj real(real64), allocatable :: Points(:, :) real(real64) :: center(3) Points = obj%getPoints() ! search Intersect leaf center(1) = sum(Points(:, 1))/dble(size(Points, 1)) center(2) = sum(Points(:, 2))/dble(size(Points, 1)) center(3) = sum(Points(:, 3))/dble(size(Points, 1)) end function ! ################################################################ ! ################################################################ subroutine syncSoybean(obj, mpid, from) class(Soybean_), intent(inout) :: obj type(MPI_), intent(inout) :: mpid integer(int32), intent(in) :: from call mpid%BcastMPIcharN(N=20, from=from, val=obj%growth_habit(1:20)) call mpid%BcastMPIcharN(N=2, from=from, val=obj%growth_stage(1:2)) call mpid%bcast(from=from, val=obj%Num_Of_Node) call mpid%bcast(from=from, val=obj%num_leaf) call mpid%bcast(from=from, val=obj%num_stem_node) call mpid%bcast(from=from, val=obj%Num_Of_Root) call mpid%bcast(from=from, val=obj%MaxLeafNum) call mpid%bcast(from=from, val=obj%MaxRootNum) call mpid%bcast(from=from, val=obj%MaxStemNum) call mpid%bcast(from=from, val=obj%determinate) !! call mpid%bcast(from=from, val=obj%ms_node) call mpid%BcastMPIIntVecFixedSize(from=from, val=obj%br_node) call mpid%BcastMPIIntVecFixedSize(from=from, val=obj%br_from) !! call mpid%bcastMPIReal(from=from, val=obj%ms_length) call mpid%bcastMPIReal(from=from, val=obj%ms_width) ! call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%br_length) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%br_width) !! !! call mpid%bcast(from=from, val=obj%ms_angle_ave) call mpid%bcast(from=from, val=obj%ms_angle_sig) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%br_angle_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%br_angle_sig) !!! !!! call mpid%bcast(from=from, val=obj%mr_node) call mpid%bcast(from=from, val=obj%mr_length) call mpid%bcast(from=from, val=obj%mr_width) ! call mpid%BcastMPIIntVecFixedSize(from=from, val=obj%brr_node) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%brr_length) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%brr_width) ! call mpid%bcast(from=from, val=obj%mr_angle_ave) call mpid%bcast(from=from, val=obj%mr_angle_sig) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%brr_angle_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%brr_angle_sig) !! call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%peti_size_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%peti_size_sig) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%peti_width_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%peti_width_sig) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%peti_angle_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%peti_angle_sig) ! call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_angle_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_angle_sig) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_length_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_length_sig) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_width_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_width_sig) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_thickness_ave) call mpid%BcastMPIRealVecFixedSize(from=from, val=obj%leaf_thickness_sig) !! call mpid%BcastMPICharN(N=3, from=from, val=obj%Stage) ! VE, CV, V1,V2, ..., R1, R2, ..., R8 call mpid%BcastMPICharN(N=200, from=from, val=obj%name) call mpid%bcast(from=from, val=obj%stage_id) call mpid%bcast(from=from, val=obj%dt) ! !! !! ! material info call mpid%bcast(from=from, val=obj%stemYoungModulus) call mpid%bcast(from=from, val=obj%leafYoungModulus) call mpid%bcast(from=from, val=obj%rootYoungModulus) !! call mpid%bcast(from=from, val=obj%stemPoissonRatio) call mpid%bcast(from=from, val=obj%leafPoissonRatio) call mpid%bcast(from=from, val=obj%rootPoissonRatio) !! call mpid%bcast(from=from, val=obj%stemDensity) call mpid%bcast(from=from, val=obj%leafDensity) call mpid%bcast(from=from, val=obj%rootDensity) !! call mpid%bcast(from=from, val=obj%leaf2stem) call mpid%bcast(from=from, val=obj%stem2stem) call mpid%bcast(from=from, val=obj%root2stem) call mpid%bcast(from=from, val=obj%root2root) !! ! call mpid%bcast(from=from, val=obj%time) call mpid%bcast(from=from, val=obj%seed_length) call mpid%bcast(from=from, val=obj%seed_width) call mpid%bcast(from=from, val=obj%seed_height) call mpid%bcast(from=from, val=obj%stem_angle) call mpid%bcast(from=from, val=obj%root_angle) call mpid%bcast(from=from, val=obj%leaf_angle) !! call mpid%BcastMPICharN(N=200, from=from, val=obj%stemconfig) call mpid%BcastMPICharN(N=200, from=from, val=obj%rootconfig) call mpid%BcastMPICharN(N=200, from=from, val=obj%leafconfig) !! !! ! for deformation analysis call mpid%bcast(from=from, val=obj%property_deform_material_density) call mpid%bcast(from=from, val=obj%property_deform_material_YoungModulus) call mpid%bcast(from=from, val=obj%property_deform_material_CarbonDiffusionCoefficient) call mpid%bcast(from=from, val=obj%property_deform_material_PoissonRatio) call mpid%bcast(from=from, val=obj%property_deform_initial_Displacement) call mpid%bcast(from=from, val=obj%property_deform_initial_Stress) call mpid%bcast(from=from, val=obj%property_deform_boundary_TractionForce) call mpid%bcast(from=from, val=obj%property_deform_boundary_Displacement) call mpid%bcast(from=from, val=obj%property_deform_gravity) !! call mpid%bcast(from=from, val=obj%Gravity_acceralation) call mpid%bcast(from=from, val=obj%PenaltyParameter) call mpid%bcast(from=from, val=obj%GaussPointProjection) !! !! !! call mpid%bcast(from=from, val=obj%NodeID_MainStem) ! !! call mpid%bcast(from=from, val=obj%inLoop) call mpid%bcast(from=from, val=obj%hours) ! ! 節-節点データ構造 call obj%struct%sync(from=from, mpid=mpid) ! ! 器官オブジェクト配列 call syncFEMDomainVector(this=obj%leaf_list, from=from, mpid=mpid) call syncFEMDomainVector(this=obj%stem_list, from=from, mpid=mpid) call syncFEMDomainVector(this=obj%root_list, from=from, mpid=mpid) ! ! type(Seed_) :: Seed ! type(PlantNode_),allocatable :: NodeSystem(:) ! type(PlantRoot_),allocatable :: RootSystem(:) call syncStemVector(obj=obj%Stem, from=from, mpid=mpid) call syncLeafVector(obj=obj%Leaf, from=from, mpid=mpid) call syncRootVector(obj=obj%Root, from=from, mpid=mpid) ! ! シミュレータ ! type(ContactMechanics_) :: contact call syncsoybean_NodeID_BranchVector(obj%NodeID_Branch, from=from, mpid=mpid) end subroutine ! ################################################################ subroutine syncSoybeans(soybeans, mpid) type(MPI_), intent(inout) :: mpid type(Soybean_), intent(inout) :: soybeans(:) integer(int32) :: id, slot_id, stack_id integer(int32), allocatable :: localstack(:) if (.not. allocated(mpid%localstack)) then call mpid%createstack(size(soybeans)) end if ! 同期 do slot_id = 1, size(mpid%stack, 1) do stack_id = 1, size(mpid%stack, 2) id = mpid%stack(slot_id, stack_id) if (id == 0) then cycle else call soybeans(id)%sync(from=slot_id - 1, mpid=mpid) end if end do end do end subroutine ! ################################################################ subroutine syncsoybean_NodeID_Branch(obj, from, mpid) class(soybean_NodeID_Branch_), intent(inout) :: obj integer(int32), intent(in) :: from type(MPI_), intent(inout) :: mpid call mpid%bcast(from=from, val=obj%id) end subroutine ! ################################################################ subroutine syncsoybean_NodeID_BranchVector(obj, from, mpid) type(soybean_NodeID_Branch_), allocatable, intent(inout) :: obj(:) integer(int32), intent(in) :: from type(MPI_), intent(inout) :: mpid integer(int32) :: vec_size, i vec_size = 0 if (mpid%myrank == from) then if (.not. allocated(obj)) then vec_size = -1 else vec_size = size(obj) end if end if call mpid%bcast(from=from, val=vec_size) if (vec_size < 1) then return end if if (from /= mpid%myrank) then if (allocated(obj)) then deallocate (obj) end if allocate (obj(vec_size)) end if do i = 1, vec_size call obj(i)%sync(from=from, mpid=mpid) end do end subroutine ! ################################################################ subroutine rotateSoybean(obj, x, y, z) class(Soybean_), intent(inout) :: obj real(real64), optional, intent(in) :: x, y, z type(FEMDomain_) :: domain ! get points domain%mesh%nodcoord = obj%getpoints() ! rotate points call domain%rotate(x=x, y=y, z=z) ! set points call obj%setPoints(domain%mesh%nodcoord) end subroutine ! ################################################################ ! ################################################################ function getDisplacementSoybean(obj, ground_level, penalty, traction_force, debug, itrmax, tol) result(disp) class(Soybean_), target, intent(inout) :: obj real(real64), intent(in) :: ground_level real(real64), optional, intent(in) :: penalty, tol, traction_force(:) logical, optional, intent(in) ::debug integer(int32), optional, intent(in) ::itrmax type(FEMDomainp_), allocatable :: FEMDomainPointers(:) type(FEMSolver_) :: solver real(real64), allocatable :: disp(:) integer(int32) :: stem_id, leaf_id, root_id, DomainID, ElementID, i, n, offset integer(int32) :: myStemID, yourStemID, myLeafID, myRootID, yourRootID integer(int32), allocatable :: FixBoundary(:) ! linear elasticity with infinitesimal strain theory n = obj%numStem() + obj%numLeaf() + obj%numRoot() allocate (FEMDomainPointers(n)) !(1) >> compute overset ! For stems if (allocated(obj%stem2stem)) then do myStemID = 1, size(obj%stem2stem, 1) do yourStemID = 1, size(obj%stem2stem, 2) if (obj%stem2stem(myStemID, yourStemID) >= 1) then ! connected call obj%stem(myStemID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=myStemID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%leaf2stem)) then do myLeafID = 1, size(obj%leaf2stem, 1) do yourStemID = 1, size(obj%leaf2stem, 2) if (obj%leaf2stem(myLeafID, yourStemID) >= 1) then ! connected call obj%leaf(myLeafID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + myLeafID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%root2stem)) then do myRootID = 1, size(obj%root2stem, 1) do yourStemID = 1, size(obj%root2stem, 2) if (obj%root2stem(myRootID, yourStemID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + obj%numLeaf() + myRootID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%root2root)) then do myRootID = 1, size(obj%root2root, 1) do yourrootID = 1, size(obj%root2root, 2) if (obj%root2root(myRootID, yourrootID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%root(yourrootID)%femdomain, & DomainID=obj%numroot() + obj%numLeaf() + yourrootID, & MyDomainID=obj%numroot() + obj%numLeaf() + myRootID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (present(debug)) then if (debug) then print *, "[ok] overset >> done." end if end if call solver%init(NumDomain=obj%numStem() + obj%numLeaf() + obj%numRoot()) FEMDomainPointers = obj%getFEMDomainPointers() call solver%setDomain(FEMDomainPointers=FEMDomainPointers) if (present(debug)) then if (debug) then print *, "[ok] initSolver >> done." end if end if call solver%setCRS(DOF=3, debug=debug) ! CRS ready! if (.not. obj%checkYoungModulus()) then print *, "[ERROR] YoungModulus(:) is not ready." stop end if if (.not. obj%checkPoissonRatio()) then print *, "[ERROR] PoissonRatio(:) is not ready." stop end if if (.not. obj%checkDensity()) then print *, "[ERROR] Density(:) is not ready." stop end if if (present(debug)) then if (debug) then print *, "[ok] setCRS >> done." end if end if !!$OMP parallel !!$OMP do !$OMP parallel do private(ElementID) do DomainID = 1, size(FEMDomainPointers) do ElementID = 1, FEMDomainPointers(DomainID)%femdomainp%ne() call solver%setMatrix(DomainID=DomainID, ElementID=ElementID, DOF=3, & Matrix=FEMDomainPointers(DomainID)%femdomainp%StiffnessMatrix( & ElementID=ElementID, & E=obj%getYoungModulus(DomainID=DomainID, ElementID=ElementID), & v=obj%getPoissonRatio(DomainID=DomainID, ElementID=ElementID))) call solver%setVector(DomainID=DomainID, ElementID=ElementID, DOF=3, & Vector=FEMDomainPointers(DomainID)%femdomainp%MassVector( & ElementID=ElementID, & DOF=FEMDomainPointers(DomainID)%femdomainp%nd(), & Density=obj%getDensity(DomainID=DomainID, ElementID=ElementID), & Accel=[0.0d0, 0.0d0, -9.80d0] & ) & ) end do end do !$OMP end parallel do if (present(debug)) then if (debug) then print *, "[ok] set Matrix & vectors >> done." end if end if call solver%setEbOM(penalty=input(default=10000000.0d0, option=penalty), DOF=3) if (present(debug)) then if (debug) then print *, "[ok] set EbOM >> done." end if end if ! traction boundary condition if (present(traction_force)) then if (size(traction_force) /= size(solver%CRS_RHS)) then print *, "[ERROR] > getDisplacementSoybean > (size(traction_force)/=size(solver%CRS_RHS) )" stop end if solver%CRS_RHS(:) = solver%CRS_RHS(:) + traction_force(:) end if ! fix-boundary conditions offset = 0 do i = 1, size(FEMDomainPointers) if (FEMDomainPointers(i)%FEMDomainp%z_min() <= ground_level) then FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max=ground_level)*3 - 2 FixBoundary = FixBoundary + offset call solver%fix(IDs=FixBoundary, FixValue=0.0d0) FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max=ground_level)*3 - 1 FixBoundary = FixBoundary + offset call solver%fix(IDs=FixBoundary, FixValue=0.0d0) FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max=ground_level)*3 - 0 FixBoundary = FixBoundary + offset call solver%fix(IDs=FixBoundary, FixValue=0.0d0) end if offset = offset + FEMDomainPointers(i)%femdomainp%nn()*3 end do if (present(debug)) then if (debug) then print *, "[ok] FixBoundary >> done." end if end if if (present(debug)) then solver%debug = debug end if if (present(itrmax)) then solver%itrmax = itrmax end if if (present(tol)) then solver%er0 = tol end if print *, "dbf" disp = solver%solve() call solver%remove() if (present(debug)) then if (debug) then print *, "[ok] Solve >> done." end if end if ! japanese "ato-shimatsu" end function ! ################################################################ ! ################################################################ function getFEMDomainPointersSoybean(obj, algorithm) result(FEMDomainPointers) class(Soybean_), target, intent(inout) :: obj integer(int32), optional, intent(in) :: algorithm type(FEMDomainp_), allocatable :: FEMDomainPointers(:) integer(int32) :: num_FEMDomain, i, n, yourStemID, myStemID, yourLeafID, myLeafID, & yourRootID, myRootID, EbO_Algorithm EbO_algorithm = input(default=FEMDomain_Overset_GPP, option=algorithm) num_FEMDomain = obj%numStem() + obj%numLeaf() + obj%numRoot() allocate (FEMDomainPointers(num_FEMDomain)) n = 0 do i = 1, obj%numStem() if (.not. obj%stem(i)%femdomain%empty()) then n = n + 1 FEMDomainPointers(n)%femdomainp => obj%stem(i)%femdomain end if end do do i = 1, obj%numLeaf() if (.not. obj%leaf(i)%femdomain%empty()) then n = n + 1 FEMDomainPointers(n)%femdomainp => obj%leaf(i)%femdomain end if end do do i = 1, obj%numRoot() if (.not. obj%root(i)%femdomain%empty()) then n = n + 1 FEMDomainPointers(n)%femdomainp => obj%root(i)%femdomain end if end do ! for overset n = obj%numStem() + obj%numLeaf() + obj%numRoot() !(1) >> compute overset ! For stems if (allocated(obj%stem2stem)) then do myStemID = 1, size(obj%stem2stem, 1) do yourStemID = 1, size(obj%stem2stem, 2) if (obj%stem2stem(myStemID, yourStemID) >= 1) then ! connected call obj%stem(myStemID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=myStemID, & algorithm=EbO_algorithm) end if end do end do end if if (allocated(obj%leaf2stem)) then do myLeafID = 1, size(obj%leaf2stem, 1) do yourStemID = 1, size(obj%leaf2stem, 2) if (obj%leaf2stem(myLeafID, yourStemID) >= 1) then ! connected call obj%leaf(myLeafID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + myLeafID, & algorithm=EbO_algorithm) end if end do end do end if if (allocated(obj%root2stem)) then do myRootID = 1, size(obj%root2stem, 1) do yourStemID = 1, size(obj%root2stem, 2) if (obj%root2stem(myRootID, yourStemID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + obj%numLeaf() + myRootID, & algorithm=EbO_algorithm) end if end do end do end if if (allocated(obj%root2root)) then do myRootID = 1, size(obj%root2root, 1) do yourrootID = 1, size(obj%root2root, 2) if (obj%root2root(myRootID, yourrootID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%root(yourrootID)%femdomain, & DomainID=obj%numroot() + obj%numLeaf() + yourrootID, & MyDomainID=obj%numroot() + obj%numLeaf() + myRootID, & algorithm=EbO_algorithm) end if end do end do end if end function ! ################################################################ ! ################################################################ function getObjectPointersSoybean(obj) result(FEMDomainPointers) class(Soybean_), target, intent(in) :: obj type(FEMDomainp_), allocatable :: FEMDomainPointers(:) integer(int32) :: num_FEMDomain, i, n ! order: stem -> leaf -> root num_FEMDomain = obj%numStem() + obj%numLeaf() + obj%numRoot() allocate (FEMDomainPointers(num_FEMDomain)) n = 0 do i = 1, obj%numStem() n = n + 1 FEMDomainPointers(n)%femdomainp => obj%stem(i)%femdomain end do do i = 1, obj%numLeaf() n = n + 1 FEMDomainPointers(n)%femdomainp => obj%leaf(i)%femdomain end do do i = 1, obj%numRoot() n = n + 1 FEMDomainPointers(n)%femdomainp => obj%root(i)%femdomain end do end function ! ################################################################ ! ################################################################ function checkYoungModulusSoybean(obj) result(all_young_modulus_is_set) class(Soybean_), intent(in) :: obj logical :: all_young_modulus_is_set integer(int32) :: i ! order: stem -> leaf -> root all_young_modulus_is_set = .true. do i = 1, obj%numStem() if (.not. allocated(obj%stem(i)%YoungModulus)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkYoungModulusSoybean >> Young Modulus is not set" print *, "@ Stem ID:", i print *, "check it by: allocated(this%stem("+str(i) + ")%YoungModulus)" return end if end do do i = 1, obj%numLeaf() if (.not. allocated(obj%Leaf(i)%YoungModulus)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkYoungModulusSoybean >> Young Modulus is not set" print *, "@ Leaf ID:", i print *, "check it by: allocated(this%Leaf("+str(i) + ")%YoungModulus)" return end if end do do i = 1, obj%numRoot() if (.not. allocated(obj%Root(i)%YoungModulus)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkYoungModulusSoybean >> Young Modulus is not set" print *, "@ Root ID:", i print *, "check it by: allocated(this%Root("+str(i) + ")%YoungModulus)" return end if end do end function ! ################################################################ ! ################################################################ function checkPoissonRatioSoybean(obj) result(all_young_modulus_is_set) class(Soybean_), intent(in) :: obj logical :: all_young_modulus_is_set integer(int32) :: i ! order: stem -> leaf -> root all_young_modulus_is_set = .true. do i = 1, obj%numStem() if (.not. allocated(obj%stem(i)%PoissonRatio)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkPoissonRatioSoybean >> Young Modulus is not set" print *, "@ Stem ID:", i print *, "check it by: allocated(this%stem("+str(i) + ")%PoissonRatio)" return end if end do do i = 1, obj%numLeaf() if (.not. allocated(obj%Leaf(i)%PoissonRatio)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkPoissonRatioSoybean >> Young Modulus is not set" print *, "@ Leaf ID:", i print *, "check it by: allocated(this%Leaf("+str(i) + ")%PoissonRatio)" return end if end do do i = 1, obj%numRoot() if (.not. allocated(obj%Root(i)%PoissonRatio)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkPoissonRatioSoybean >> Young Modulus is not set" print *, "@ Root ID:", i print *, "check it by: allocated(this%Root("+str(i) + ")%PoissonRatio)" return end if end do end function ! ################################################################ ! ################################################################ function checkDensitySoybean(obj) result(all_young_modulus_is_set) class(Soybean_), intent(in) :: obj logical :: all_young_modulus_is_set integer(int32) :: i ! order: stem -> leaf -> root all_young_modulus_is_set = .true. do i = 1, obj%numStem() if (.not. allocated(obj%stem(i)%Density)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkDensitySoybean >> Young Modulus is not set" print *, "@ Stem ID:", i print *, "check it by: allocated(this%stem("+str(i) + ")%Density)" return end if end do do i = 1, obj%numLeaf() if (.not. allocated(obj%Leaf(i)%Density)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkDensitySoybean >> Young Modulus is not set" print *, "@ Leaf ID:", i print *, "check it by: allocated(this%Leaf("+str(i) + ")%Density)" return end if end do do i = 1, obj%numRoot() if (.not. allocated(obj%Root(i)%Density)) then all_young_modulus_is_set = .false. print *, "[!Warning!] checkDensitySoybean >> Young Modulus is not set" print *, "@ Root ID:", i print *, "check it by: allocated(this%Root("+str(i) + ")%Density)" return end if end do end function ! ################################################################ ! ################################################################ function getYoungModulusSoybean(obj, DomainID, ElementID) result(YoungModulus) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: DomainID, ElementID real(real64) :: YoungModulus integer(int32) :: i, n if (DomainID > obj%numStem() + obj%numLeaf() + obj%numRoot()) then print *, "ERROR :: getYoungModulusSoybean >> DomainID exceeds max_domain_size" return end if ! default >> search @ all domains ! order: stem -> leaf -> root if (DomainID <= obj%numStem()) then n = DomainID - 0 YoungModulus = obj%stem(n)%YoungModulus(ElementID) return elseif (obj%numStem() + 1 <= DomainID .and. DomainID <= obj%numStem() + obj%numLeaf()) then n = DomainID - obj%numStem() YoungModulus = obj%leaf(n)%YoungModulus(ElementID) return else n = DomainID - obj%numStem() - obj%numLeaf() YoungModulus = obj%root(n)%YoungModulus(ElementID) return end if end function ! ################################################################ ! ################################################################ function getPoissonRatioSoybean(obj, DomainID, ElementID) result(PoissonRatio) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: DomainID, ElementID real(real64) :: PoissonRatio integer(int32) :: i, n if (DomainID > obj%numStem() + obj%numLeaf() + obj%numRoot()) then print *, "ERROR :: getPoissonRatioSoybean >> DomainID exceeds max_domain_size" return end if ! default >> search @ all domains ! order: stem -> leaf -> root if (DomainID <= obj%numStem()) then n = DomainID - 0 PoissonRatio = obj%stem(n)%PoissonRatio(ElementID) return elseif (obj%numStem() + 1 <= DomainID .and. DomainID <= obj%numStem() + obj%numLeaf()) then n = DomainID - obj%numStem() PoissonRatio = obj%leaf(n)%PoissonRatio(ElementID) return else n = DomainID - obj%numStem() - obj%numLeaf() PoissonRatio = obj%root(n)%PoissonRatio(ElementID) return end if end function ! ################################################################ ! ################################################################ function getDensitySoybean(obj, DomainID, ElementID) result(Density) class(Soybean_), intent(in) :: obj integer(int32), intent(in) :: DomainID, ElementID real(real64) :: Density integer(int32) :: i, n if (DomainID > obj%numStem() + obj%numLeaf() + obj%numRoot()) then print *, "ERROR :: getDensitySoybean >> DomainID exceeds max_domain_size" return end if ! default >> search @ all domains ! order: stem -> leaf -> root if (DomainID <= obj%numStem()) then n = DomainID - 0 Density = obj%stem(n)%Density(ElementID) return elseif (obj%numStem() + 1 <= DomainID .and. DomainID <= obj%numStem() + obj%numLeaf()) then n = DomainID - obj%numStem() Density = obj%leaf(n)%Density(ElementID) return else n = DomainID - obj%numStem() - obj%numLeaf() Density = obj%root(n)%Density(ElementID) return end if end function ! ################################################################ subroutine checkMemoryRequirementSoybean(obj) class(Soybean_), intent(in) :: Obj real(real64) :: re_val integer(int64) :: val print *, "====================================" print *, "checking Memory (RAM) Requirement..." print *, "------------------------------------" print *, "| Object type | Soybean" print *, "| Number of points | "+str(obj%nn()) print *, "| Degree of freedom | Deformation | "+str(obj%nn()*3) print *, "| | ModeAnalysis| "+str(obj%nn()*3*obj%nn()*3) print *, "| | Diffusion | "+str(obj%nn()) print *, "| | Reaction | "+str(obj%nn()) print *, "| DRAM requirement | Deformation | "+str(obj%nn()*3*40*30/1000/1000) + " (MB)" val = obj%nn()*3*30 val = val*obj%nn()*3/1000/1000 print *, "| | ModeAnalysis| ", str(val), " (MB)" print *, "| | Diffusion | "+str(obj%nn()*1*20*10/1000/1000) + " (MB)" print *, "| | Reaction | "+str(obj%nn()*1*20*10/1000/1000) + " (MB)" print *, "====================================" end subroutine ! ################################################################ recursive subroutine setYoungModulusSoybean(obj, YoungModulus, stem, root, leaf, ElementList) class(Soybean_), intent(inout) :: obj logical, optional, intent(in) :: stem, root, leaf ! ElementList(Idx, [TYPE, DOMAIN, ELEMENT]) integer(int32), optional, intent(in) :: ElementList(:, :) real(real64), intent(in) :: YoungModulus integer(int32) :: i, j, n, domain_idx, elem_idx n = 0 if (present(stem)) then if (stem) then n = n + 1 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_STEM) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%stem(domain_idx)%YoungModulus(elem_idx) = YoungModulus end if end do else obj%stem(i)%YoungModulus = YoungModulus*eyes(obj%stem(i)%femdomain%ne()) end if end do end if end if end if if (present(leaf)) then if (leaf) then n = n + 10 if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_LEAF) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%LEAF(domain_idx)%YoungModulus(elem_idx) = YoungModulus end if end do else obj%leaf(i)%YoungModulus = YoungModulus*eyes(obj%leaf(i)%femdomain%ne()) end if end do end if end if end if if (present(root)) then if (root) then n = n + 100 if (allocated(obj%root)) then do i = 1, size(obj%root) if (obj%root(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_ROOT) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%ROOT(domain_idx)%YoungModulus(elem_idx) = YoungModulus end if end do else obj%root(i)%YoungModulus = YoungModulus*eyes(obj%root(i)%femdomain%ne()) end if end do end if end if end if if (n == 0) then call obj%setYoungModulus(YoungModulus=YoungModulus, stem=.true., root=.true., leaf=.true., & ElementList=ElementList) end if end subroutine ! ################################################################ ! ################################################################ recursive subroutine setPoissonRatioSoybean(obj, PoissonRatio, stem, root, leaf, ElementList) class(Soybean_), intent(inout) :: obj logical, optional, intent(in) :: stem, root, leaf ! ElementList(Idx, [TYPE, DOMAIN, ELEMENT]) integer(int32), optional, intent(in) :: ElementList(:, :) real(real64), intent(in) :: PoissonRatio integer(int32) :: i, j, n, domain_idx, elem_idx n = 0 if (present(stem)) then if (stem) then n = n + 1 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_STEM) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%stem(domain_idx)%PoissonRatio(elem_idx) = PoissonRatio end if end do else obj%stem(i)%PoissonRatio = PoissonRatio*eyes(obj%stem(i)%femdomain%ne()) end if end do end if end if end if if (present(leaf)) then if (leaf) then n = n + 10 if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_LEAF) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%LEAF(domain_idx)%PoissonRatio(elem_idx) = PoissonRatio end if end do else obj%leaf(i)%PoissonRatio = PoissonRatio*eyes(obj%leaf(i)%femdomain%ne()) end if end do end if end if end if if (present(root)) then if (root) then n = n + 100 if (allocated(obj%root)) then do i = 1, size(obj%root) if (obj%root(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_ROOT) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%ROOT(domain_idx)%PoissonRatio(elem_idx) = PoissonRatio end if end do else obj%root(i)%PoissonRatio = PoissonRatio*eyes(obj%root(i)%femdomain%ne()) end if end do end if end if end if if (n == 0) then call obj%setPoissonRatio(PoissonRatio=PoissonRatio, stem=.true., root=.true., leaf=.true., & ElementList=ElementList) end if end subroutine ! ################################################################ ! ################################################################ recursive subroutine setDensitySoybean(obj, Density, stem, root, leaf, ElementList) class(Soybean_), intent(inout) :: obj logical, optional, intent(in) :: stem, root, leaf ! ElementList(Idx, [TYPE, DOMAIN, ELEMENT]) integer(int32), optional, intent(in) :: ElementList(:, :) real(real64), intent(in) :: Density integer(int32) :: i, j, n, domain_idx, elem_idx n = 0 if (present(stem)) then if (stem) then n = n + 1 if (allocated(obj%stem)) then do i = 1, size(obj%stem) if (obj%stem(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_STEM) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%stem(domain_idx)%Density(elem_idx) = Density end if end do else obj%stem(i)%Density = Density*eyes(obj%stem(i)%femdomain%ne()) end if end do end if end if end if if (present(leaf)) then if (leaf) then n = n + 10 if (allocated(obj%leaf)) then do i = 1, size(obj%leaf) if (obj%leaf(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_LEAF) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%LEAF(domain_idx)%Density(elem_idx) = Density end if end do else obj%leaf(i)%Density = Density*eyes(obj%leaf(i)%femdomain%ne()) end if end do end if end if end if if (present(root)) then if (root) then n = n + 100 if (allocated(obj%root)) then do i = 1, size(obj%root) if (obj%root(i)%femdomain%empty()) then cycle elseif (present(ElementList)) then do j = 1, size(ElementList, 1) if (ElementList(j, 1) == obj%TYPE_ROOT) then domain_idx = ElementList(j, 2) elem_idx = ElementList(j, 3) obj%ROOT(domain_idx)%Density(elem_idx) = Density end if end do else obj%root(i)%Density = Density*eyes(obj%root(i)%femdomain%ne()) end if end do end if end if end if if (n == 0) then call obj%setDensity(Density=Density, stem=.true., root=.true., leaf=.true., & ElementList=ElementList) end if end subroutine ! ################################################################ ! ################################################################ function getEigenModeSoybean(obj, ground_level, penalty, debug, Frequency, EbOM_Algorithm, & num_mode, femsolver) result(EigenVectors) class(Soybean_), target, intent(inout) :: obj real(real64), intent(in) :: ground_level real(real64), optional, intent(in) :: penalty logical, optional, intent(in) :: debug real(real64), allocatable, intent(inout) :: Frequency(:) character(*), optional, intent(in) :: EbOM_Algorithm !integer(int32),optional,intent(in) :: num_mode integer(int32), optional, intent(in) :: num_mode type(FEMSolver_), optional, intent(inout):: femsolver integer(int32) :: num_freq type(FEMDomainp_), allocatable :: FEMDomainPointers(:) type(FEMSolver_) :: solver type(Math_) :: math real(real64), allocatable :: EigenVectors(:, :), buf(:, :), buf_vec(:) integer(int32) :: stem_id, leaf_id, root_id, DomainID, ElementID, i, n integer(int32) :: myStemID, yourStemID, myLeafID, myRootID, yourRootID integer(int32), allocatable :: FixBoundary(:) integer(int32) :: nn_domains, EbOM_Algorithm_id real(real64) :: vec_norm real(real64), allocatable :: all_frequency(:), All_EigenVectors(:, :) if (present(femsolver)) then solver = femsolver end if num_freq = input(default=10, option=num_mode) EbOM_Algorithm_id = FEMDomain_Overset_GPP if (present(EbOM_Algorithm)) then if (EbOM_Algorithm == "P2P") then EbOM_Algorithm_id = FEMDomain_Overset_P2P elseif (EbOM_Algorithm == "GPP") then EbOM_Algorithm_id = FEMDomain_Overset_P2P end if end if ! linear elasticity with infinitesimal strain theory n = obj%numStem() + obj%numLeaf() + obj%numRoot() allocate (FEMDomainPointers(n)) !(1) >> compute overset ! For stems if (allocated(obj%stem2stem)) then if (allocated(obj%stem)) then do myStemID = 1, size(obj%stem2stem, 1) do yourStemID = 1, size(obj%stem2stem, 2) if (obj%stem2stem(myStemID, yourStemID) >= 1) then ! connected call obj%stem(myStemID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=myStemID, & algorithm=EbOM_Algorithm_id) ! or "P2P" call obj%stem(yourStemID)%femdomain%overset( & FEMDomain=obj%stem(myStemID)%femdomain, & DomainID=myStemID, & MyDomainID=yourStemID, & algorithm=EbOM_Algorithm_id) ! or "P2P" end if end do end do end if end if if (allocated(obj%leaf2stem)) then if (allocated(obj%leaf) .and. allocated(obj%stem)) then do myLeafID = 1, size(obj%leaf2stem, 1) do yourStemID = 1, size(obj%leaf2stem, 2) if (obj%leaf2stem(myLeafID, yourStemID) >= 1) then ! connected call obj%leaf(myLeafID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + myLeafID, & algorithm=EbOM_Algorithm_id) ! or "P2P" !call obj%stem(yourStemID)%femdomain%overset(& ! FEMDomain=obj%leaf(myLeafID)%femdomain, ! DomainID =obj%numStem() + myLeafID, ! MyDomainID= yourStemID, ! algorithm=EbOM_Algorithm_id ) ! or "P2P" end if end do end do end if end if if (allocated(obj%root2stem)) then if (allocated(obj%stem) .and. allocated(obj%root)) then do myRootID = 1, size(obj%root2stem, 1) do yourStemID = 1, size(obj%root2stem, 2) if (obj%root2stem(myRootID, yourStemID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + obj%numLeaf() + myRootID, & algorithm=EbOM_Algorithm_id) ! or "P2P" call obj%stem(yourStemID)%femdomain%overset( & FEMDomain=obj%root(myRootID)%femdomain, & DomainID=obj%numStem() + obj%numLeaf() + myRootID, & MyDomainID=yourStemID, & algorithm=EbOM_Algorithm_id) ! or "P2P" end if end do end do end if end if if (allocated(obj%root2root)) then if (allocated(obj%root)) then do myRootID = 1, size(obj%root2root, 1) do yourrootID = 1, size(obj%root2root, 2) if (obj%root2root(myRootID, yourrootID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%root(yourrootID)%femdomain, & DomainID=obj%numroot() + obj%numLeaf() + yourrootID, & MyDomainID=obj%numroot() + obj%numLeaf() + myRootID, & algorithm=EbOM_Algorithm_id) ! or "P2P" call obj%root(yourrootID)%femdomain%overset( & FEMDomain=obj%root(myRootID)%femdomain, & DomainID=obj%numroot() + obj%numLeaf() + myRootID, & MyDomainID=obj%numroot() + obj%numLeaf() + yourrootID, & algorithm=EbOM_Algorithm_id) ! or "P2P" end if end do end do end if end if if (present(debug)) then if (debug) then print *, "[ok] overset >> done." end if end if call solver%init(NumDomain=obj%numStem() + obj%numLeaf() + obj%numRoot()) FEMDomainPointers = obj%getFEMDomainPointers() call solver%setDomain(FEMDomainPointers=FEMDomainPointers) if (present(debug)) then if (debug) then print *, "[ok] initSolver >> done." end if end if call solver%setCRS(DOF=3, debug=debug) ! CRS ready! if (.not. obj%checkYoungModulus()) then print *, "[ERROR] YoungModulus(:) is not ready." stop end if if (.not. obj%checkPoissonRatio()) then print *, "[ERROR] PoissonRatio(:) is not ready." stop end if if (.not. obj%checkDensity()) then print *, "[ERROR] Density(:) is not ready." stop end if if (present(debug)) then if (debug) then print *, "[ok] setCRS >> done." end if end if !!$OMP parallel !!$OMP do !$OMP parallel do private(ElementID) do DomainID = 1, size(FEMDomainPointers) do ElementID = 1, FEMDomainPointers(DomainID)%femdomainp%ne() call solver%setMatrix(DomainID=DomainID, ElementID=ElementID, DOF=3, & Matrix=FEMDomainPointers(DomainID)%femdomainp%StiffnessMatrix( & ElementID=ElementID, & E=obj%getYoungModulus(DomainID=DomainID, ElementID=ElementID), & v=obj%getPoissonRatio(DomainID=DomainID, ElementID=ElementID))) end do end do !$OMP end parallel do if (present(debug)) then if (debug) then print *, "[ok] set Matrix & vectors >> done." end if end if call solver%setEbOM(penalty=input(default=10000000.0d0, option=penalty), DOF=3) if (present(debug)) then if (debug) then print *, "[ok] set EbOM >> done." end if end if call solver%keepThisMatrixAs("A") !call solver%saveMatrix(name="A",CRS_as_dense=.true.,zero_or_nonzero=.true) call solver%zeros() ! mass matrix !$OMP parallel do private(ElementID) do DomainID = 1, size(FEMDomainPointers) do ElementID = 1, FEMDomainPointers(DomainID)%femdomainp%ne() call solver%setMatrix(DomainID=DomainID, ElementID=ElementID, DOF=3, & Matrix=FEMDomainPointers(DomainID)%femdomainp%massMatrix( & ElementID=ElementID, & Density=obj%getDensity(DomainID=DomainID, ElementID=ElementID), & DOF=3)) end do end do !$OMP end parallel do call solver%keepThisMatrixAs("B") ! fix-boundary conditions nn_domains = 0 do i = 1, size(FEMDomainPointers) if (FEMDomainPointers(i)%FEMDomainp%z_min() <= ground_level) then FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max=ground_level)*3 - 2 + nn_domains*3 call solver%fix_eig(IDs=FixBoundary) FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max=ground_level)*3 - 1 + nn_domains*3 call solver%fix_eig(IDs=FixBoundary) FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max=ground_level)*3 - 0 + nn_domains*3 call solver%fix_eig(IDs=FixBoundary) end if nn_domains = nn_domains + FEMDomainPointers(i)%FEMDomainp%nn() end do if (present(debug)) then if (debug) then print *, "[ok] FixBoundary >> done." end if end if if (present(debug)) then solver%debug = debug end if call solver%eig(eigen_value=All_Frequency, eigen_vectors=All_EigenVectors) if (present(femsolver)) then femsolver = solver end if call solver%remove() if (All_Frequency(1) <= 0.0d0) then return end if ! simplify this part ! normalize EigenVectors do i = 1, size(All_EigenVectors, 2) vec_norm = norm(All_EigenVectors(:, i)) All_EigenVectors(:, i) = All_EigenVectors(:, i)/vec_norm end do Frequency = zeros(num_freq) EigenVectors = zeros(size(All_EigenVectors, 1), num_freq) do i = 1, num_freq n = minvalID(All_Frequency) EigenVectors(:, i) = All_EigenVectors(:, n) Frequency(i) = All_Frequency(n) All_Frequency(n) = maxval(All_Frequency) end do do i = 1, size(Frequency) if (Frequency(i) < 0.0d0) then Frequency(i) = 0.0d0 end if end do Frequency = sqrt((Frequency))/(2.0d0*math%PI) if (present(debug)) then if (debug) then print *, "[ok] Solve >> done." end if end if end function ! ################################################################ subroutine resizeStemSoybean(this, StemID, InterNodeID, Length, Width) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: stemID, InterNodeID real(real64), optional, intent(in) :: Length, Width real(real64) :: current_length integer(int32) :: i, j, node_id node_id = 0 do i = 1, size(this%stem, 1) if (this%stem(i)%stemID == StemID) then if (this%stem(i)%InterNodeID == InterNodeID) then node_id = i end if end if end do if (node_id == 0) then print *, "resizeStemSoybean 404 Not Found." return end if call this%stem(node_id)%change_length_or_width(length=Length, Width=Width) call this%update() end subroutine subroutine rotateStemSoybean(this, StemID, InterNodeID, Angles) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: stemID, InterNodeID real(real64), intent(in) :: Angles(1:3) real(real64) :: current_length integer(int32) :: i, j, node_id do i = 1, size(this%stem, 1) if (this%stem(i)%stemID == StemID) then if (this%stem(i)%InterNodeID == InterNodeID) then node_id = i end if end if end do if (node_id == 0) then print *, "resizeStemSoybean 404 Not Found." return end if call this%stem(node_id)%femdomain%rotate(x=Angles(1), y=Angles(2), z=Angles(3), deg=.true.) call this%update() end subroutine function searchStemSoybean(this, StemID, InterNodeID) result(node_id) class(Soybean_), intent(in) :: this integer(int32), intent(in) :: stemID, InterNodeID real(real64) :: current_length integer(int32) :: i, j, node_id node_id = -404 if (StemID == 0) then if (1 <= InterNodeID .and. InterNodeID <= size(this%NodeID_MainStem)) then node_id = this%NodeID_MainStem(InterNodeID) else return end if else if (.not. allocated(this%NodeID_Branch)) then return end if if (1 <= StemID .and. StemID <= size(this%NodeID_Branch)) then if (allocated(this%NodeID_Branch(StemID)%ID)) then node_id = this%NodeID_Branch(StemID)%ID(InterNodeID) end if end if end if ! do i=1,size(this%stem,1) ! if(this%stem(i)%stemID==StemID)then ! if(this%stem(i)%InterNodeID==InterNodeID)then ! node_id = i ! endif ! endif ! enddo end function function searchPetioleSoybean(this, StemID, InterNodeID, PetioleID) result(node_id) class(Soybean_), intent(in) :: this integer(int32), intent(in) :: stemID, InterNodeID, PetioleID real(real64) :: current_length integer(int32) :: i, j, node_id, n node_id = -404 node_id = this%searchStem(StemID=StemID, InterNodeID=InterNodeID) if (node_id < 0) then return end if n = 0 do i = 1, size(this%stem2stem, 1) if (this%stem2stem(i, node_id) == 1 & .and. this%stem(i)%StemID == -1) then n = n + 1 if (n == PetioleID) then node_id = i return end if end if end do node_id = -404404 end function function searchLeafSoybean(this, StemID, InterNodeID, PetioleID, LeafID) result(leaf_id) class(Soybean_), intent(in) :: this integer(int32), intent(in) :: stemID, InterNodeID, PetioleID, LeafID real(real64) :: current_length integer(int32) :: i, j, node_id, n, petiole_id, leaf_id leaf_id = -404404404 petiole_id = -404404 node_id = -404 petiole_id = this%searchPetiole( & StemID=StemID, & ! main=0, branch=1,2 ... InterNodeID=InterNodeID, & ! 1,2,3... PetioleID=PetioleID & ) if (petiole_id < 0) then leaf_id = -404 return end if do i = 1, size(this%leaf2stem, 1) if (this%leaf2stem(i, petiole_id) == 1) then if (this%leaf(i)%leafID == LeafID) then leaf_id = i end if end if end do end function ! ############################################################################# subroutine resizePetioleSoybean(this, StemID, InterNodeID, PetioleID, Length, Width) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: stemID, InterNodeID, PetioleID real(real64), optional, intent(in) :: Length, Width real(real64) :: current_length integer(int32) :: i, j, node_id node_id = this%searchPetiole(StemID=StemID, InterNodeID=InterNodeID, PetioleID=PetioleID) if (node_id < 1) then print *, "resizePetioleSoybean 404 Not Found." return end if call this%stem(node_id)%change_length_or_width(length=Length, Width=Width) call this%update() end subroutine ! ############################################################################# ! ############################################################################# subroutine rotatePetioleSoybean(this, StemID, InterNodeID, PetioleID, Angles) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: stemID, InterNodeID, PetioleID real(real64), intent(in) :: Angles(1:3) real(real64) :: current_length integer(int32) :: i, j, node_id node_id = this%searchPetiole(StemID=StemID, InterNodeID=InterNodeID, PetioleID=PetioleID) if (node_id < 1) then print *, "rotatePetioleSoybean 404 Not Found." return end if call this%stem(node_id)%femdomain%rotate(x=Angles(1), y=Angles(2), z=Angles(3), deg=.true.) call this%update() end subroutine ! ######################################################### subroutine resizeLeafSoybean(this, StemID, InterNodeID, PetioleID, LeafID, Length, Width) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: stemID, InterNodeID, PetioleID, LeafID real(real64), optional, intent(in) :: Length, Width real(real64) :: current_length integer(int32) :: i, j, leaf_id leaf_id = this%searchLeaf(StemID=StemID, InterNodeID=InterNodeID, PetioleID=PetioleID, & LeafID=LeafID) if (leaf_id < 1) then print *, "resizeLeafSoybean 404 Not Found." return end if call this%leaf(leaf_id)%resize(length=Length, Width=Width) call this%update() end subroutine ! ######################################################### function maxStemIDSoybean(this) result(ret) class(Soybean_), intent(in) :: this integer(int32) :: ret, i, buf ret = 0 do i = 1, size(this%Stem, 1) buf = this%maxInterNodeID(StemID=i) if (buf >= 1) then ret = ret + 1 else return end if end do end function ! ######################################################### ! ######################################################### function maxInterNodeIDSoybean(this, StemID) result(ret) class(Soybean_), intent(in) :: this integer(int32), intent(in) :: StemID integer(int32) :: ret, i, buf ret = 0 if (StemID == 0) then if (allocated(this%NodeID_MainStem)) then ret = size(this%NodeID_MainStem) else ret = 0 end if else if (allocated(this%NodeID_Branch)) then ret = size(this%NodeID_Branch(StemID)%ID) else ret = 0 end if end if ! do i=1, size(this%Stem,1) ! buf = this%searchStem(StemID=StemID,InterNodeID=i) ! if(buf >=1)then ! ret = ret + 1 ! else ! cycle ! endif ! enddo end function ! ######################################################### ! ######################################################### function maxPetioleIDSoybean(this, StemID, InterNodeID) result(ret) class(Soybean_), intent(in) :: this integer(int32), intent(in) :: StemID, InterNodeID integer(int32) :: ret, i, buf, PerioleID ret = 0 do i = 1, size(this%Stem, 1) buf = this%searchPetiole(StemID=StemID, InterNodeID=InterNodeID, PetioleID=i) if (buf >= 1) then ret = ret + 1 else return end if end do end function ! ######################################################### ! ######################################################### function maxleafIDSoybean(this, StemID, InterNodeID, PetioleID) result(ret) class(Soybean_), intent(in) :: this integer(int32), intent(in) :: StemID, InterNodeID, PetioleID integer(int32) :: ret, i, buf, PerioleID ret = 0 do i = 1, size(this%Leaf, 1) buf = this%searchLeaf(StemID=StemID, InterNodeID=InterNodeID, PetioleID=PetioleID, & LeafID=i) if (buf >= 1) then ret = ret + 1 else return end if end do end function ! ######################################################### ! ################################################################ subroutine growStemSoybean(this, StemID, InterNodeID, dt) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: stemID, InterNodeID real(real64), intent(in) :: dt real(real64) :: current_length integer(int32) :: i, j, node_id node_id = 0 do i = 1, size(this%stem, 1) if (this%stem(i)%stemID == StemID) then if (this%stem(i)%InterNodeID == InterNodeID) then node_id = i end if end if end do if (node_id == 0) then print *, "resizeStemSoybean 404 Not Found." return end if call this%stem(node_id)%change_length_or_width(dt) call this%update() end subroutine ! ############################################# subroutine setFinalInternodeLengthSoybean(this, Length, StemID) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: StemID real(real64), intent(in) :: Length(:) if (.not. allocated(this%InterNodeInfo)) then allocate (this%InterNodeInfo(0:this%MaxBranchNum)) end if this%InterNodeInfo(StemID)%FinalInterNodeLength = Length end subroutine ! ############################################# subroutine setFinalPetioleLengthSoybean(this, Length, StemID) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: StemID real(real64), intent(in) :: Length(:) if (.not. allocated(this%InterNodeInfo)) then allocate (this%InterNodeInfo(0:this%MaxBranchNum)) end if this%InterNodeInfo(StemID)%FinalPetioleLength = Length end subroutine ! ############################################# subroutine setFinalLeafLengthSoybean(this, Length, StemID) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: StemID real(real64), intent(in) :: Length(:) if (.not. allocated(this%InterNodeInfo)) then allocate (this%InterNodeInfo(0:this%MaxBranchNum)) end if this%InterNodeInfo(StemID)%FinalLeafLength = Length end subroutine ! ############################################# subroutine setFinalLeafWidthSoybean(this, Width, StemID) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: StemID real(real64), intent(in) :: Width(:) if (.not. allocated(this%InterNodeInfo)) then allocate (this%InterNodeInfo(0:this%MaxBranchNum)) end if this%InterNodeInfo(StemID)%FinalLeafWidth = Width end subroutine ! ################################################################ function getYoungModulusFieldSoybean(this) result(YoungModulus) class(Soybean_), intent(inout) :: this real(real64), allocatable :: YoungModulus(:) integer(int32), allocatable :: ElementList(:, :) integer(int32) :: TYPE_IDX, DOMAIN_IDX, ELEMENT_IDX, i ElementList = this%getElementList() YoungModulus = zeros(size(ElementList, 1)) do i = 1, size(ElementList, 1) TYPE_IDX = ElementList(i, 1) DOMAIN_IDX = ElementList(i, 2) ELEMENT_IDX = ElementList(i, 3) if (TYPE_IDX == this%TYPE_STEM) then YoungModulus(i) = this%stem(DOMAIN_IDX)%YoungModulus(ELEMENT_IDX) elseif (TYPE_IDX == this%TYPE_LEAF) then YoungModulus(i) = this%LEAF(DOMAIN_IDX)%YoungModulus(ELEMENT_IDX) elseif (TYPE_IDX == this%TYPE_ROOT) then YoungModulus(i) = this%ROOT(DOMAIN_IDX)%YoungModulus(ELEMENT_IDX) end if end do end function ! ################################################################ ! ################################################################ function getPoissonRatioFieldSoybean(this) result(PoissonRatio) class(Soybean_), intent(inout) :: this real(real64), allocatable :: PoissonRatio(:) integer(int32), allocatable :: ElementList(:, :) integer(int32) :: TYPE_IDX, DOMAIN_IDX, ELEMENT_IDX, i ElementList = this%getElementList() PoissonRatio = zeros(size(ElementList, 1)) do i = 1, size(ElementList, 1) TYPE_IDX = ElementList(i, 1) DOMAIN_IDX = ElementList(i, 2) ELEMENT_IDX = ElementList(i, 3) if (TYPE_IDX == this%TYPE_STEM) then PoissonRatio(i) = this%stem(DOMAIN_IDX)%PoissonRatio(ELEMENT_IDX) elseif (TYPE_IDX == this%TYPE_LEAF) then PoissonRatio(i) = this%LEAF(DOMAIN_IDX)%PoissonRatio(ELEMENT_IDX) elseif (TYPE_IDX == this%TYPE_ROOT) then PoissonRatio(i) = this%ROOT(DOMAIN_IDX)%PoissonRatio(ELEMENT_IDX) end if end do end function ! ################################################################ ! ################################################################ function getDensityFieldSoybean(this) result(Density) class(Soybean_), intent(inout) :: this real(real64), allocatable :: Density(:) integer(int32), allocatable :: ElementList(:, :) integer(int32) :: TYPE_IDX, DOMAIN_IDX, ELEMENT_IDX, i ElementList = this%getElementList() Density = zeros(size(ElementList, 1)) do i = 1, size(ElementList, 1) TYPE_IDX = ElementList(i, 1) DOMAIN_IDX = ElementList(i, 2) ELEMENT_IDX = ElementList(i, 3) if (TYPE_IDX == this%TYPE_STEM) then Density(i) = this%stem(DOMAIN_IDX)%Density(ELEMENT_IDX) elseif (TYPE_IDX == this%TYPE_LEAF) then Density(i) = this%LEAF(DOMAIN_IDX)%Density(ELEMENT_IDX) elseif (TYPE_IDX == this%TYPE_ROOT) then Density(i) = this%ROOT(DOMAIN_IDX)%Density(ELEMENT_IDX) end if end do end function ! ##################################################################### function getGlobalElementIdxSoybean(this, x_min, x_max, y_min, y_max, z_min, z_max, debug) result(GlobalElementIdx) class(Soybean_), intent(inout) :: this integer(int32), allocatable :: GlobalElementIdx(:) logical, optional, intent(in) :: debug logical :: do_debug real(real64), optional, intent(in) :: x_min, x_max, y_min, y_max, z_min, z_max integer(int32) :: offset, idx if (present(debug)) then do_debug = debug else do_debug = .false. end if offset = 0 allocate (GlobalElementIdx(0)) if (allocated(this%stem)) then do idx = 1, size(this%stem) if (this%stem(idx)%femdomain%empty()) cycle GlobalElementIdx = & GlobalElementIdx//(this%stem(idx)%femdomain%mesh%getElementList( & xmin=x_min, xmax=x_max, ymin=y_min, ymax=y_max, zmin=z_min, zmax=z_max) + offset) offset = offset + this%stem(idx)%femdomain%ne() end do if (do_debug) then print *, "[o] STEM" end if else if (do_debug) then print *, "NO STEM" end if end if if (allocated(this%leaf)) then do idx = 1, size(this%leaf) if (this%leaf(idx)%femdomain%empty()) cycle GlobalElementIdx = & GlobalElementIdx//(this%leaf(idx)%femdomain%mesh%getElementList( & xmin=x_min, xmax=x_max, ymin=y_min, ymax=y_max, zmin=z_min, zmax=z_max) + offset) offset = offset + this%leaf(idx)%femdomain%ne() end do if (do_debug) then print *, "[o] LEAF" end if else if (do_debug) then print *, "NO LEAF" end if end if if (allocated(this%root)) then do idx = 1, size(this%root) if (this%root(idx)%femdomain%empty()) cycle GlobalElementIdx = & GlobalElementIdx//(this%root(idx)%femdomain%mesh%getElementList( & xmin=x_min, xmax=x_max, ymin=y_min, ymax=y_max, zmin=z_min, zmax=z_max) + offset) offset = offset + this%root(idx)%femdomain%ne() end do if (do_debug) then print *, "[o] ROOT" end if else if (do_debug) then print *, "NO ROOT" end if end if end function ! ##################################################################### function getElementListSoybean(this, x_min, x_max, y_min, y_max, z_min, z_max, debug) result(ElementList) class(Soybean_), intent(inout) :: this integer(int32), allocatable :: ElementList(:, :) integer(int32), allocatable :: obj_type(:), obj_idx(:), elem_idx(:) real(real64), optional, intent(in) :: x_min, x_max, y_min, y_max, z_min, z_max logical, optional, intent(in) :: debug logical :: do_debug integer(int32) :: idx, n, m do_debug = input(default=.false., option=debug) !ElementList(idx, [ObjType, ObjID, ElementID] ) allocate (elem_idx(0)) allocate (obj_type(0)) allocate (obj_idx(0)) if (allocated(this%stem)) then do idx = 1, size(this%stem) if (this%stem(idx)%femdomain%empty()) cycle m = size(elem_idx) elem_idx = & elem_idx//this%stem(idx)%femdomain%mesh%getElementList( & xmin=x_min, xmax=x_max, ymin=y_min, ymax=y_max, zmin=z_min, zmax=z_max) obj_idx = obj_idx//idx*int(eyes(size(elem_idx) - m)) end do if (do_debug) then print *, "[o] STEM" end if else if (do_debug) then print *, "NO STEM" end if end if ! debug obj_type = obj_type//this%TYPE_STEM*int(eyes(size(elem_idx))) if (allocated(this%leaf)) then do idx = 1, size(this%leaf) if (this%leaf(idx)%femdomain%empty()) cycle m = size(elem_idx) elem_idx = & elem_idx//this%leaf(idx)%femdomain%mesh%getElementList( & xmin=x_min, xmax=x_max, ymin=y_min, ymax=y_max, zmin=z_min, zmax=z_max) obj_idx = obj_idx//idx*int(eyes(size(elem_idx) - m)) end do if (do_debug) then print *, "[o] LEAF" end if else if (do_debug) then print *, "NO LEAF" end if end if n = size(obj_type) obj_type = obj_type//this%TYPE_LEAF*int(eyes(size(elem_idx) - n)) if (allocated(this%root)) then do idx = 1, size(this%root) if (this%root(idx)%femdomain%empty()) cycle m = size(elem_idx) elem_idx = & elem_idx//this%root(idx)%femdomain%mesh%getElementList( & xmin=x_min, xmax=x_max, ymin=y_min, ymax=y_max, zmin=z_min, zmax=z_max) obj_idx = obj_idx//idx*int(eyes(size(elem_idx) - m)) end do if (do_debug) then print *, "[o] ROOT" end if else if (do_debug) then print *, "NO ROOT" end if end if n = size(obj_type) obj_type = obj_type//this%TYPE_ROOT*int(eyes(size(elem_idx) - n)) ElementList = zeros(size(elem_idx), 3) ElementList(:, 1) = obj_type ElementList(:, 2) = obj_idx ElementList(:, 3) = elem_idx end function ! ################################################################ ! ################################################################ function getStressFieldSoybean(this, displacement, i, j, option) result(StressField) class(Soybean_), intent(inout) :: this real(real64), intent(in) :: displacement(:) integer(int32), optional, intent(in) :: i, j character(*), optional, intent(in) :: option real(real64), allocatable :: StressField(:) integer(int32) :: ii, jj, n, obj_idx StressField = zeros(0) n = 1 if (allocated(this%stem)) then do obj_idx = 1, size(this%stem) if (this%stem(obj_idx)%femdomain%mesh%empty()) cycle StressField = StressField// & this%stem(obj_idx)%femdomain%getElementCauchyStress( & displacement=displacement(n:n + this%stem(obj_idx)%femdomain%nn() & *this%stem(obj_idx)%femdomain%nd() - 1), & E=this%stem(obj_idx)%YoungModulus(:), & v=this%stem(obj_idx)%PoissonRatio(:), i=i, j=j, option=option) n = n + this%stem(obj_idx)%femdomain%nn() & *this%stem(obj_idx)%femdomain%nd() end do end if if (allocated(this%leaf)) then do obj_idx = 1, size(this%leaf) if (this%leaf(obj_idx)%femdomain%mesh%empty()) cycle StressField = StressField// & this%leaf(obj_idx)%femdomain%getElementCauchyStress( & displacement=displacement(n:n + this%leaf(obj_idx)%femdomain%nn() & *this%leaf(obj_idx)%femdomain%nd() - 1), & E=this%leaf(obj_idx)%YoungModulus(:), & v=this%leaf(obj_idx)%PoissonRatio(:), i=i, j=j, option=option) n = n + this%leaf(obj_idx)%femdomain%nn() & *this%leaf(obj_idx)%femdomain%nd() end do end if if (allocated(this%root)) then do obj_idx = 1, size(this%root) if (this%root(obj_idx)%femdomain%mesh%empty()) cycle StressField = StressField// & this%root(obj_idx)%femdomain%getElementCauchyStress( & displacement=displacement(n:n + this%root(obj_idx)%femdomain%nn() & *this%root(obj_idx)%femdomain%nd() - 1), & E=this%root(obj_idx)%YoungModulus(:), & v=this%root(obj_idx)%PoissonRatio(:), i=i, j=j, option=option) n = n + this%root(obj_idx)%femdomain%nn() & *this%root(obj_idx)%femdomain%nd() end do end if end function ! ################################################################ subroutine export_eigSoybean(this, name, Frequency, ModeVectors, stress_type) class(Soybean_), intent(inout) :: this character(*), intent(in) :: Name character(*), optional, intent(in) :: stress_type real(real64), intent(in) :: Frequency(:), ModeVectors(:, :) real(real64), allocatable :: displacement(:), stress(:) integer(int32) :: i, j type(IO_) :: f call f%open(name + ".csv", "w") call f%write("# Mode, Eigenfrequency (Hz)") do i = 1, 10 displacement = ModeVectors(:, i) do j = 1, 36 call this%deform(displacement=cos(radian(j*10.0d0))*displacement) if (present(stress_type)) then stress = this%getStressField(Displacement=cos(radian(j*10.0d0))*displacement, option=stress_type) call this%vtk(name + zfill(i, 3) + "_"+zfill(j, 4), single_file=.true., scalar_field=stress) else call this%vtk(name + zfill(i, 3) + "_"+zfill(j, 4), single_file=.true.) end if call this%deform(displacement=-cos(radian(j*10.0d0))*displacement) end do write (f%fh, *) str(i) + " , ", Frequency(i) end do call f%close() end subroutine ! ################################################################ function getCarbon_concentrationSoybean(this, env, FixBoundary, FixValue) result(ret) class(Soybean_), intent(in) :: this type(Environment_), intent(in) :: env integer(int32), allocatable, intent(inout) :: FixBoundary(:) real(real64), allocatable, intent(inout) :: FixValue(:) real(real64), allocatable :: ret(:) integer(int32), allocatable :: apicals(:), NumberOfElement(:), NumberOfPoint(:) integer(int32) :: stemID, apical_id, from, to, itr, i, k ! getCarbon_concentrationSoybean if (allocated(FixValue)) deallocate (FixValue) if (allocated(FixBoundary)) deallocate (FixBoundary) ! Unit :: ___________micro-gram/m^3/s_____________ ! reaction term ! 濃度勾配駆動で流れるとして，その固定濃度，負値は無視 ret = -1.0d0*eyes(this%ne()) allocate (FixValue(0)) allocate (FixBoundary(0)) apicals = this%findApical() NumberOfElement = this%getNumberOfElement() NumberOfPoint = this%getNumberOfPoint() !itr = 0 do apical_id = 1, size(apicals) if (this%stem(apicals(apical_id))%empty()) then cycle else ! element-wise values to = sum(NumberOfElement(1:apicals(apical_id))) from = to + 1 - this%stem(apicals(apical_id))%ne() ret(from + this%stem(apicals(apical_id))%B_PointElementID) = this%apical_carbon_concentration ! node-wise values to = sum(NumberOfPoint(1:apicals(apical_id))) from = to + 1 - this%stem(apicals(apical_id))%nn() FixBoundary = FixBoundary//[from + this%stem(apicals(apical_id))%B_PointNodeID] FixValue = FixValue//[this%apical_carbon_concentration] itr = itr + 1 end if end do end function ! ################################################################ function ElementID2NodeIDSoybean(this, ElementIDs) result(NodeIDs) class(Soybean_), intent(in) :: this integer(int32), intent(in) :: ElementIDs(:) integer(int32), allocatable :: NodeIDs(:), numberOfElement(:), domain_in(:), idx(:), nidx(:) integer(int32) :: offset, domainID, i, j numberOfElement = this%getNumberOfElement() domain_in = ElementIDs domain_in(:) = 0 offset = 0 do i = 1, size(numberOfElement) do j = 1, size(ElementIDs) if (offset + 1 <= ElementIDs(j) .and. ElementIDs(j) <= offset + numberOfElement(i)) then domain_in(j) = i else cycle end if end do offset = offset + numberOfElement(i) end do offset = 0 domainID = 0 if (allocated(this%stem)) then do i = 1, size(this%stem) if (this%stem(i)%empty()) cycle domainID = domainID + 1 idx = getIdx(domain_in, equal_to=DomainID) if (size(idx) == 0) then cycle else nidx = this%stem(i)%femdomain%ElementID2NodeID(ElementID=idx) if (.not. allocated(nodeIDs)) then nodeIDs = nidx(:) + offset else nodeIDs = nodeIDs//(nidx(:) + offset) end if end if offset = offset + this%stem(i)%nn() end do end if end function ! ################################################################ function getRespirationSoybean(this, env) result(ret) class(Soybean_), intent(in) :: this type(Environment_), intent(in) :: env integer(int32) :: stemid, rootid, from, to real(real64), allocatable :: ret(:) integer(int32), allocatable :: NumberOfElement(:) ! getCarbon_concentrationSoybean micro-gram/m^3 ! reaction term ! Unit :: ___________micro-gram/m^3/s_____from mincro-mol/m-2/s NumberOfElement = this%getNumberOfElement() ret = zeros(this%ne()) do stemid = 1, this%numStem() if (this%stem(stemid)%empty()) cycle to = sum(NumberOfElement(1:stemID)) from = to - this%stem(stemID)%ne() + 1 ret(from:to) = this%stem(stemid)%R_d*180.160d0/6.0d0/0.00020d0 end do ! ignore leaf since it is contained in the %GetPhotosynthesis if (allocated(this%root)) then do rootID = 1, this%numRoot() if (this%root(rootID)%empty()) cycle to = sum(NumberOfElement(1:this%numStem() + this%numLeaf() + rootID)) from = to - this%root(rootID)%ne() + 1 ret(from:to) = this%root(rootID)%R_d*180.160d0/6.0d0/0.00020d0 end do end if end function ! ###################################################### function getCarbonFlowSoybean(this, photosynthesis, respiration, FixBoundary, FixValue, & Photosynthate_n, dt, penalty, DiffusionCoeff, debug, RHS, Matrix, & tol, algorithm) & result(Photosynthate) class(Soybean_), target, intent(inout) :: this type(CRS_), optional, intent(inout) :: Matrix real(real64), intent(in) :: photosynthesis(:), respiration(:), Photosynthate_n(:), & dt, DiffusionCoeff(:), FixValue(:) integer(int32), intent(in) :: FixBoundary(:) real(real64), intent(in) :: penalty real(real64), optional, intent(in) :: tol character(*), optional, intent(in) :: algorithm real(real64) :: dx real(real64), allocatable :: c(:) logical, optional, intent(in) :: debug real(real64), allocatable :: Photosynthate(:) real(real64), allocatable, optional, intent(inout) :: RHS(:) logical :: passed type(FEMDomain_), allocatable :: FEMDomains(:) type(DiffusionEq_) :: solver integer(int32) :: i, n, num_fix_bound, total_nn type(IO_) :: f ! num_fix_bound = 0 ! do i=1,size(carbon_concentration) ! if(carbon_concentration(i) > 0.0d0 ) then ! num_fix_bound = num_fix_bound + 1 ! endif ! enddo ! ! FixValue = zeros(num_fix_bound) ! FixBoundary = int(zeros(num_fix_bound)) ! ! ! num_fix_bound = 0 ! do i=1,size(carbon_concentration) ! if(carbon_concentration(i) > 0.0d0 ) then ! num_fix_bound = num_fix_bound + 1 ! FixBoundary(num_fix_bound) = i ! FixValue(num_fix_bound) = carbon_concentration(i) ! endif ! enddo FEMDomains = this%to_FEMDomains() if (present(debug)) then solver%solver%debug = debug end if do i = 1, size(femdomains) call femdomains(i)%vtk("mesh_"+zfill(i, 4)) if (femdomains(i)%empty()) stop end do if (present(tol)) then solver%solver%er0 = tol solver%solver%relative_er = tol end if if (allocated(this%reaction_n)) then solver%CRS_RHS_n = this%reaction_n end if dx = abs(FEMDomains(1)%position_x(1) - FEMDomains(1)%position_x(2)) call solver%check_stability_condition(dt=dt, dx=dx, coefficient=average(DiffusionCoeff), passed=passed) if (.not. passed) then print *, "[getCarbonFlowSoybean] >> dt is too large!" stop end if if (present(algorithm)) then Photosynthate = solver%getDiffusionField( & FEMDomains=FEMDomains, & DiffusionCoeff=DiffusionCoeff, & Reaction=photosynthesis - respiration, & Penalty=penalty, & FixBoundary=FixBoundary, & FixValue=FixValue, & C_n=Photosynthate_n, & RHS=RHS, & algorithm=algorithm, & Matrix=Matrix, & dt=dt & ) else Photosynthate = solver%getDiffusionField( & FEMDomains=FEMDomains, & DiffusionCoeff=DiffusionCoeff, & Reaction=photosynthesis - respiration, & Penalty=penalty, & FixBoundary=FixBoundary, & FixValue=FixValue, & C_n=Photosynthate_n, & RHS=RHS, & Matrix=Matrix, & dt=dt & ) end if this%reaction_n = solver%CRS_RHS_n end function ! ###################################################### ! ###################################################### function getDiffusionCoefficientSoybean(this) result(DiffusionCoefficient) class(Soybean_), intent(inout) :: this real(real64), allocatable :: DiffusionCoefficient(:) integer(int32) :: i, n, domainID allocate (DiffusionCoefficient(0)) if (allocated(this%stem)) then do i = 1, size(this%stem) if (this%stem(i)%empty()) cycle DiffusionCoefficient = DiffusionCoefficient//this%stem(i)%CarbonDiffusionCoefficient end do end if if (allocated(this%leaf)) then do i = 1, size(this%leaf) if (this%leaf(i)%empty()) cycle DiffusionCoefficient = DiffusionCoefficient//this%leaf(i)%CarbonDiffusionCoefficient end do end if if (allocated(this%root)) then do i = 1, size(this%root) if (this%root(i)%empty()) cycle DiffusionCoefficient = DiffusionCoefficient//this%root(i)%CarbonDiffusionCoefficient end do end if end function ! ###################################################### ! ###################################################### function to_FEMDomainsSoybean(this) result(femdomains) class(Soybean_), intent(inout) :: this type(FEMDomain_), allocatable :: femdomains(:) integer(int32) :: i, j, n, domainID integer(int32) :: stem_offset, leaf_offset, root_offset n = this%numStem() + this%numLeaf() + this%numRoot() allocate (femdomains(n)) DomainID = 0 if (allocated(this%stem)) then do i = 1, size(this%stem) if (this%stem(i)%empty()) cycle DomainID = DomainID + 1 femdomains(DomainID) = this%stem(i)%femdomain end do end if if (allocated(this%leaf)) then do i = 1, size(this%leaf) if (this%leaf(i)%empty()) cycle DomainID = DomainID + 1 femdomains(DomainID) = this%leaf(i)%femdomain end do end if if (allocated(this%root)) then do i = 1, size(this%root) if (this%root(i)%empty()) cycle DomainID = DomainID + 1 femdomains(DomainID) = this%root(i)%femdomain end do end if ! overset stem_offset = 0 leaf_offset = this%numStem() root_offset = this%numStem() + this%numLeaf() do i = 1, size(femdomains) femdomains(i)%uuid = generate_uuid(1) end do if (allocated(this%Stem2Stem)) then do i = 1, size(this%Stem2Stem, 1) do j = 1, size(this%Stem2Stem, 2) if (this%Stem2Stem(i, j) == 1) then call femdomains(i + stem_offset)%overset( & FEMDomains=femdomains, to=j + stem_offset, by="GPP") call femdomains(j + stem_offset)%overset( & FEMDomains=femdomains, to=i + stem_offset, by="GPP") end if end do end do end if if (allocated(this%Leaf2Stem)) then do i = 1, size(this%Leaf2Stem, 1) do j = 1, size(this%Leaf2Stem, 2) if (this%Leaf2Stem(i, j) > 0) then call femdomains(i + leaf_offset)%overset( & FEMDomains=femdomains, to=j + stem_offset, by="GPP") call femdomains(j + stem_offset)%overset( & FEMDomains=femdomains, to=i + leaf_offset, by="GPP") end if end do end do end if if (allocated(this%root2Stem)) then do i = 1, size(this%root2Stem, 1) do j = 1, size(this%root2Stem, 2) if (this%root2Stem(i, j) > 0) then call femdomains(i + root_offset)%overset( & FEMDomains=femdomains, to=j + stem_offset, by="GPP") call femdomains(j + stem_offset)%overset( & FEMDomains=femdomains, to=i + root_offset, by="GPP") end if end do end do end if if (allocated(this%root2root)) then do i = 1, size(this%root2root, 1) do j = 1, size(this%root2root, 2) if (this%root2root(i, j) > 0) then call femdomains(i + root_offset)%overset( & FEMDomains=femdomains, to=j + root_offset, by="GPP") call femdomains(j + root_offset)%overset( & FEMDomains=femdomains, to=i + root_offset, by="GPP") end if end do end do end if end function ! ###################################################### ! ###################################################### subroutine setFEMDomainsSoybean(this, femdomains) class(Soybean_), intent(inout) :: this type(FEMDomain_), intent(in) :: femdomains(:) integer(int32) :: i, n, domainID DomainID = 0 if (allocated(this%stem)) then do i = 1, size(this%stem) if (this%stem(i)%empty()) cycle DomainID = DomainID + 1 this%stem(i)%femdomain = femdomains(DomainID) end do end if if (allocated(this%leaf)) then do i = 1, size(this%leaf) if (this%leaf(i)%empty()) cycle DomainID = DomainID + 1 this%leaf(i)%femdomain = femdomains(DomainID) end do end if if (allocated(this%root)) then do i = 1, size(this%root) if (this%root(i)%empty()) cycle DomainID = DomainID + 1 this%root(i)%femdomain = femdomains(DomainID) end do end if end subroutine ! ###################################################### ! ################################################################## function nn_rangeSoybean(this, organ_type, ID) result(ret) class(Soybean_), intent(inout) :: this integer(int32), intent(in) :: ID character(*), intent(in) :: organ_type integer(int32) :: ret(1:2), i, offset ! get number of node (point) ret = [0, 0] offset = 0 select case (organ_type) case ("Stem", "stem", "STEM") if (allocated(this%stem)) then do i = 1, ID - 1 if (.not. this%stem(i)%femdomain%mesh%empty()) then offset = offset + this%stem(i)%femdomain%nn() end if end do ret(1) = offset + 1 ret(2) = offset + this%stem(ID)%femdomain%nn() end if case ("Leaf", "leaf", "LEAF") if (allocated(this%stem)) then do i = 1, size(this%stem) if (.not. this%stem(i)%femdomain%mesh%empty()) then offset = offset + this%stem(i)%femdomain%nn() end if end do end if if (allocated(this%leaf)) then do i = 1, ID - 1 if (.not. this%leaf(i)%femdomain%mesh%empty()) then offset = offset + this%leaf(i)%femdomain%nn() end if end do ret(1) = offset + 1 ret(2) = offset + this%leaf(ID)%femdomain%nn() end if case ("Root", "root", "ROOT") if (allocated(this%stem)) then do i = 1, size(this%stem) if (.not. this%stem(i)%femdomain%mesh%empty()) then offset = offset + this%stem(i)%femdomain%nn() end if end do end if if (allocated(this%leaf)) then do i = 1, size(this%leaf) if (.not. this%leaf(i)%femdomain%mesh%empty()) then offset = offset + this%leaf(i)%femdomain%nn() end if end do end if if (allocated(this%root)) then do i = 1, ID - 1 if (.not. this%root(i)%femdomain%mesh%empty()) then offset = offset + this%root(i)%femdomain%nn() end if end do ret(1) = offset + 1 ret(2) = offset + this%root(ID)%femdomain%nn() end if ! case ("Ear","ear","EAR") ! ! if(allocated(this%stem) )then ! if(allocated(this%stem) )then ! do i=1,size(this%stem) ! if( .not.this%stem(i)%femdomain%mesh%empty() ) then ! offset = offset + this%stem(i)%femdomain%nn() ! endif ! enddo ! endif ! if(allocated(this%leaf) )then ! do i=1,size(this%leaf) ! if( .not.this%leaf(i)%femdomain%mesh%empty() ) then ! offset = offset + this%leaf(i)%femdomain%nn() ! endif ! enddo ! endif ! if(allocated(this%root) )then ! do i=1,size(this%root) ! if( .not.this%root(i)%femdomain%mesh%empty() ) then ! offset = offset + this%root(i)%femdomain%nn() ! endif ! enddo ! endif ! if(allocated(this%ear) )then ! do i=1,ID-1 ! if( .not.this%ear(i)%femdomain%mesh%empty() ) then ! offset = offset + this%ear(i)%femdomain%nn() ! endif ! enddo ! ret(1) = offset + 1 ! ret(2) = offset + this%ear(ID)%femdomain%nn() ! endif ! endif ! case ("Panicle","panicle","PANICLE") ! if(allocated(this%stem) )then ! if(allocated(this%stem) )then ! do i=1,size(this%stem) ! if( .not.this%stem(i)%femdomain%mesh%empty() ) then ! offset = offset + this%stem(i)%femdomain%nn() ! endif ! enddo ! endif ! if(allocated(this%leaf) )then ! do i=1,size(this%leaf) ! if( .not.this%leaf(i)%femdomain%mesh%empty() ) then ! offset = offset + this%leaf(i)%femdomain%nn() ! endif ! enddo ! endif ! if(allocated(this%root) )then ! do i=1,size(this%root) ! if( .not.this%root(i)%femdomain%mesh%empty() ) then ! offset = offset + this%root(i)%femdomain%nn() ! endif ! enddo ! endif ! if(allocated(this%ear) )then ! do i=1,size(this%ear) ! if( .not.this%ear(i)%femdomain%mesh%empty() ) then ! offset = offset + this%ear(i)%femdomain%nn() ! endif ! enddo ! endif ! if(allocated(this%panicle) )then ! do i=1,ID-1 ! if( .not.this%panicle(i)%femdomain%mesh%empty() ) then ! offset = offset + this%panicle(i)%femdomain%nn() ! endif ! enddo ! ret(1) = offset + 1 ! ret(2) = offset + this%panicle(ID)%femdomain%nn() ! endif ! endif ! end select end function ! ################################################################## ! ################################################################ subroutine getVerticesSoybean(this, Vertices, VertexIDs) class(Soybean_), intent(inout) :: this real(real64), allocatable, intent(inout) :: Vertices(:) integer(int32), allocatable, intent(inout) :: VertexIDs(:) real(real64), allocatable :: this_vertices(:) integer(int32), allocatable :: nn_range(:), this_vertexIDs(:) integer(int32) :: i, n, new_idx real(real64), allocatable :: old_Vertices(:) integer(int32), allocatable :: old_VertexIDs(:) Vertices = zeros(this%nn()*3) VertexIDs = int(zeros(this%nn())) if (allocated(this%stem)) then !$OMP parallel do private(nn_range,this_vertices,this_vertexIDs) do i = 1, size(this%stem) if (.not. this%stem(i)%femdomain%Mesh%empty()) then call this%stem(i)%femdomain%getVertices(this_vertices, this_vertexIDs) nn_range = this%nn_range("stem", i) Vertices(3*(nn_range(1) - 1) + 1:3*(nn_range(1) - 1) + size(this_vertices)) = this_vertices(:) VertexIDs(nn_range(1):nn_range(1) - 1 + size(this_vertexIDs)) = nn_range(1) - 1 + this_vertexIDs(:) deallocate (this_vertices) deallocate (this_vertexIDs) end if end do !$OMP end parallel do end if if (allocated(this%leaf)) then !$OMP parallel do private(nn_range,this_vertices,this_vertexIDs) do i = 1, size(this%leaf) if (.not. this%leaf(i)%femdomain%Mesh%empty()) then call this%leaf(i)%femdomain%getVertices(this_vertices, this_vertexIDs) nn_range = this%nn_range("leaf", i) Vertices(3*(nn_range(1) - 1) + 1:3*(nn_range(1) - 1) + size(this_vertices)) = this_vertices(:) VertexIDs(nn_range(1):nn_range(1) - 1 + size(this_vertexIDs)) = nn_range(1) - 1 + this_vertexIDs(:) deallocate (this_vertices) deallocate (this_vertexIDs) end if end do !$OMP end parallel do end if if (allocated(this%root)) then !$OMP parallel do private(nn_range,this_vertices,this_vertexIDs) do i = 1, size(this%root) if (.not. this%root(i)%femdomain%Mesh%empty()) then call this%root(i)%femdomain%getVertices(this_vertices, this_vertexIDs) nn_range = this%nn_range("root", i) Vertices(3*(nn_range(1) - 1) + 1:3*(nn_range(1) - 1) + size(this_vertices)) = this_vertices(:) VertexIDs(nn_range(1):nn_range(1) - 1 + size(this_vertexIDs)) = nn_range(1) - 1 + this_vertexIDs(:) deallocate (this_vertices) deallocate (this_vertexIDs) end if end do !$OMP end parallel do end if ! if VertexIDs(:) = 0 then ! remove vertices old_VertexIDs = VertexIDs old_Vertices = Vertices n = size(VertexIDs) - countif(Array=VertexIDs, Equal=.true., Value=0) deallocate (VertexIDs) deallocate (Vertices) allocate (VertexIDs(n)) allocate (Vertices(3*n)) new_idx = 0 do i = 1, size(old_VertexIDs) if (old_VertexIDs(i) == 0) then cycle else new_idx = new_idx + 1 VertexIDs(new_idx) = old_VertexIDs(i) Vertices(3*(new_idx - 1) + 1:3*(new_idx - 1) + 3) = old_Vertices(3*(i - 1) + 1:3*(i - 1) + 3) end if end do end subroutine getVerticesSoybean ! ################################################################ function MassMatrixSoybean(obj, debug) result(ret) class(Soybean_), target, intent(inout) :: obj ! real(real64),intent(in) :: ground_level ! real(real64),optional,intent(in) :: penalty, tol,traction_force(:) logical, optional, intent(in) ::debug type(CRS_) :: ret ! integer(int32),optional,intent(in) ::itrmax type(FEMDomainp_), allocatable :: FEMDomainPointers(:) type(FEMSolver_) :: solver integer(int32) :: stem_id, leaf_id, root_id, DomainID, ElementID, i, n, offset integer(int32) :: myStemID, yourStemID, myLeafID, myRootID, yourRootID integer(int32), allocatable :: FixBoundary(:) ! linear elasticity with infinitesimal strain theory n = obj%numStem() + obj%numLeaf() + obj%numRoot() allocate (FEMDomainPointers(n)) !(1) >> compute overset ! For stems if (allocated(obj%stem2stem)) then do myStemID = 1, size(obj%stem2stem, 1) do yourStemID = 1, size(obj%stem2stem, 2) if (obj%stem2stem(myStemID, yourStemID) >= 1) then ! connected call obj%stem(myStemID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=myStemID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%leaf2stem)) then do myLeafID = 1, size(obj%leaf2stem, 1) do yourStemID = 1, size(obj%leaf2stem, 2) if (obj%leaf2stem(myLeafID, yourStemID) >= 1) then ! connected call obj%leaf(myLeafID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + myLeafID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%root2stem)) then do myRootID = 1, size(obj%root2stem, 1) do yourStemID = 1, size(obj%root2stem, 2) if (obj%root2stem(myRootID, yourStemID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + obj%numLeaf() + myRootID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%root2root)) then do myRootID = 1, size(obj%root2root, 1) do yourrootID = 1, size(obj%root2root, 2) if (obj%root2root(myRootID, yourrootID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%root(yourrootID)%femdomain, & DomainID=obj%numroot() + obj%numLeaf() + yourrootID, & MyDomainID=obj%numroot() + obj%numLeaf() + myRootID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (present(debug)) then if (debug) then print *, "[ok] overset >> done." end if end if call solver%init(NumDomain=obj%numStem() + obj%numLeaf() + obj%numRoot()) FEMDomainPointers = obj%getFEMDomainPointers() call solver%setDomain(FEMDomainPointers=FEMDomainPointers) if (present(debug)) then if (debug) then print *, "[ok] initSolver >> done." end if end if call solver%setCRS(DOF=3, debug=debug) ! CRS ready! ! if( .not. obj%checkYoungModulus())then ! print *, "[ERROR] YoungModulus(:) is not ready." ! stop ! endif ! if( .not. obj%checkPoissonRatio())then ! print *, "[ERROR] PoissonRatio(:) is not ready." ! stop ! endif if (.not. obj%checkDensity()) then print *, "[ERROR] Density(:) is not ready." stop end if if (present(debug)) then if (debug) then print *, "[ok] setCRS >> done." end if end if !$OMP parallel do private(ElementID) do DomainID = 1, size(FEMDomainPointers) do ElementID = 1, FEMDomainPointers(DomainID)%femdomainp%ne() call solver%setMatrix(DomainID=DomainID, ElementID=ElementID, DOF=3, & Matrix=FEMDomainPointers(DomainID)%femdomainp%MassMatrix( & ElementID=ElementID, & DOF=FEMDomainPointers(DomainID)%femdomainp%nd(), & Density=obj%getDensity(DomainID=DomainID, ElementID=ElementID))) end do end do !$OMP end parallel do if (present(debug)) then if (debug) then print *, "[ok] set Matrix & vectors >> done." end if end if ! call solver%setEbOM(penalty=input(default=10000000.0d0,option=penalty), DOF=3) ! if(present(debug) )then ! if(debug)then ! print *, "[ok] set EbOM >> done." ! endif ! endif ! ! ! traction boundary condition ! if(present(traction_force) )then ! if(size(traction_force)/=size(solver%CRS_RHS) )then ! print *, "[ERROR] > getDisplacementSoybean > (size(traction_force)/=size(solver%CRS_RHS) )" ! stop ! endif ! solver%CRS_RHS(:) = solver%CRS_RHS(:) + traction_force(:) ! endif ! ! ! fix-boundary conditions ! offset = 0 ! do i=1,size(FEMDomainPointers) ! if(FEMDomainPointers(i)%FEMDomainp%z_min() <= ground_level )then ! FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max = ground_level )*3-2 ! FixBoundary = FixBoundary + offset ! call solver%fix(IDs=FixBoundary,FixValue=0.0d0) ! FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max = ground_level )*3-1 ! FixBoundary = FixBoundary + offset ! call solver%fix(IDs=FixBoundary,FixValue=0.0d0) ! FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max = ground_level )*3-0 ! FixBoundary = FixBoundary + offset ! call solver%fix(IDs=FixBoundary,FixValue=0.0d0) ! endif ! offset = offset + FEMDomainPointers(i)%femdomainp%nn()*3 ! enddo ! ! if(present(debug) )then ! if(debug)then ! print *, "[ok] FixBoundary >> done." ! endif ! endif ! if (present(debug)) then solver%debug = debug end if ! if(present(itrmax) )then ! solver%itrmax = itrmax ! endif ! ! if(present(tol) )then ! solver%er0 = tol ! endif ! disp = solver%solve() ! ! ret = solver%getCRS() !call solver%remove() ! if(present(debug) )then ! if(debug)then ! print *, "[ok] Solve >> done." ! endif ! endif ! japanese "ato-shimatsu" end function ! ##################################################################### function StiffnessMatrixSoybean(obj, penalty, debug) result(ret) class(Soybean_), target, intent(inout) :: obj ! real(real64),intent(in) :: ground_level real(real64), optional, intent(in) :: penalty!, tol,traction_force(:) logical, optional, intent(in) ::debug type(CRS_) :: ret ! integer(int32),optional,intent(in) ::itrmax type(FEMDomainp_), allocatable :: FEMDomainPointers(:) type(FEMSolver_) :: solver integer(int32) :: stem_id, leaf_id, root_id, DomainID, ElementID, i, n, offset integer(int32) :: myStemID, yourStemID, myLeafID, myRootID, yourRootID integer(int32), allocatable :: FixBoundary(:) ! linear elasticity with infinitesimal strain theory n = obj%numStem() + obj%numLeaf() + obj%numRoot() allocate (FEMDomainPointers(n)) !(1) >> compute overset ! For stems if (allocated(obj%stem2stem)) then do myStemID = 1, size(obj%stem2stem, 1) do yourStemID = 1, size(obj%stem2stem, 2) if (obj%stem2stem(myStemID, yourStemID) >= 1) then ! connected call obj%stem(myStemID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=myStemID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%leaf2stem)) then do myLeafID = 1, size(obj%leaf2stem, 1) do yourStemID = 1, size(obj%leaf2stem, 2) if (obj%leaf2stem(myLeafID, yourStemID) >= 1) then ! connected call obj%leaf(myLeafID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + myLeafID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%root2stem)) then do myRootID = 1, size(obj%root2stem, 1) do yourStemID = 1, size(obj%root2stem, 2) if (obj%root2stem(myRootID, yourStemID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%stem(yourStemID)%femdomain, & DomainID=yourStemID, & MyDomainID=obj%numStem() + obj%numLeaf() + myRootID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (allocated(obj%root2root)) then do myRootID = 1, size(obj%root2root, 1) do yourrootID = 1, size(obj%root2root, 2) if (obj%root2root(myRootID, yourrootID) >= 1) then ! connected call obj%root(myRootID)%femdomain%overset( & FEMDomain=obj%root(yourrootID)%femdomain, & DomainID=obj%numroot() + obj%numLeaf() + yourrootID, & MyDomainID=obj%numroot() + obj%numLeaf() + myRootID, & algorithm=FEMDomain_Overset_GPP) ! or "P2P" end if end do end do end if if (present(debug)) then if (debug) then print *, "[ok] overset >> done." end if end if call solver%init(NumDomain=obj%numStem() + obj%numLeaf() + obj%numRoot()) FEMDomainPointers = obj%getFEMDomainPointers() call solver%setDomain(FEMDomainPointers=FEMDomainPointers) if (present(debug)) then if (debug) then print *, "[ok] initSolver >> done." end if end if call solver%setCRS(DOF=3, debug=debug) ! CRS ready! if (.not. obj%checkYoungModulus()) then print *, "[ERROR] YoungModulus(:) is not ready." stop end if if (.not. obj%checkPoissonRatio()) then print *, "[ERROR] PoissonRatio(:) is not ready." stop end if ! if( .not. obj%checkDensity())then ! print *, "[ERROR] Density(:) is not ready." ! stop ! endif if (present(debug)) then if (debug) then print *, "[ok] setCRS >> done." end if end if !$OMP parallel do private(ElementID) do DomainID = 1, size(FEMDomainPointers) do ElementID = 1, FEMDomainPointers(DomainID)%femdomainp%ne() call solver%setMatrix(DomainID=DomainID, ElementID=ElementID, DOF=3, & Matrix=FEMDomainPointers(DomainID)%femdomainp%StiffnessMatrix( & ElementID=ElementID, & E=obj%getYoungModulus(DomainID=DomainID, ElementID=ElementID), & v=obj%getPoissonRatio(DomainID=DomainID, ElementID=ElementID))) ! call solver%setVector(DomainID=DomainID,ElementID=ElementID,DOF=3,& ! Vector=FEMDomainPointers(DomainID)%femdomainp%MassVector(& ! ElementID=ElementID,& ! DOF=FEMDomainPointers(DomainID)%femdomainp%nd() ,& ! Density= obj%getDensity(DomainID=DomainID,ElementID=ElementID) ,& ! Accel=[0.0d0, 0.0d0, -9.80d0]& ! ) & ! ) end do end do !$OMP end parallel do if (present(debug)) then if (debug) then print *, "[ok] set Matrix & vectors >> done." end if end if call solver%setEbOM(penalty=input(default=10000000.0d0, option=penalty), DOF=3) if (present(debug)) then if (debug) then print *, "[ok] set EbOM >> done." end if end if ! ! traction boundary condition ! if(present(traction_force) )then ! if(size(traction_force)/=size(solver%CRS_RHS) )then ! print *, "[ERROR] > getDisplacementSoybean > (size(traction_force)/=size(solver%CRS_RHS) )" ! stop ! endif ! solver%CRS_RHS(:) = solver%CRS_RHS(:) + traction_force(:) ! endif ! ! ! fix-boundary conditions ! offset = 0 ! do i=1,size(FEMDomainPointers) ! if(FEMDomainPointers(i)%FEMDomainp%z_min() <= ground_level )then ! FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max = ground_level )*3-2 ! FixBoundary = FixBoundary + offset ! call solver%fix(IDs=FixBoundary,FixValue=0.0d0) ! FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max = ground_level )*3-1 ! FixBoundary = FixBoundary + offset ! call solver%fix(IDs=FixBoundary,FixValue=0.0d0) ! FixBoundary = FEMDomainPointers(i)%FEMDomainp%select(z_max = ground_level )*3-0 ! FixBoundary = FixBoundary + offset ! call solver%fix(IDs=FixBoundary,FixValue=0.0d0) ! endif ! offset = offset + FEMDomainPointers(i)%femdomainp%nn()*3 ! enddo if (present(debug)) then if (debug) then print *, "[ok] FixBoundary >> done." end if end if if (present(debug)) then solver%debug = debug end if ! if(present(itrmax) )then ! solver%itrmax = itrmax ! endif ! ! if(present(tol) )then ! solver%er0 = tol ! endif ! ! disp = solver%solve() ! ! ret = solver%getCRS() !call solver%remove() ! if(present(debug) )then ! if(debug)then ! print *, "[ok] Solve >> done." ! endif ! endif ! japanese "ato-shimatsu" end function ! ##################################################################### function to_R_FRSoybean(this, spectrum) result(ret) class(Soybean_), intent(in) :: this real(real64), intent(in) :: spectrum(:, :) ! global_elem_idx, nm real(real64), allocatable :: ret(:) integer(int32) :: idx ret = zeros(size(spectrum, 1)) do idx = 1, size(ret) ret(idx) = sum(spectrum(idx, 600:700))/sum(spectrum(idx, 700:800)) end do end function ! ##################################################################### ! ##################################################################### function get_stem_length_list_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64),allocatable :: ret(:) integer(int32) :: idx,i ret = zeros(this%numStem()) if (.not. allocated(this%stem)) then return end if idx = 0 do i = 1, size(this%stem) if (this%stem(i)%femdomain%Mesh%empty() .eqv. .false.) then idx = idx + 1 ret(idx) = this%stem(idx)%getLength() end if end do end function ! ##################################################################### ! ##################################################################### subroutine set_stem_length_by_list_Soybean(this,stem_length_list) class(Soybean_),intent(inout) :: this real(real64),intent(in) :: stem_length_list(:) integer(int32) :: idx,i if (.not. allocated(this%stem)) then return end if idx = 0 do i = 1, size(this%stem) if (this%stem(i)%femdomain%Mesh%empty() .eqv. .false.) then idx = idx + 1 this%stem(idx)%already_grown = False call this%stem(idx)%change_length_or_width(length=stem_length_list(idx)) end if end do call this%update() end subroutine ! ##################################################################### ! ##################################################################### subroutine set_stem_angle_by_list_Soybean(this,stem_angle_list) class(Soybean_),intent(inout) :: this real(real64),intent(in) :: stem_angle_list(:,:) real(real64) :: original_position(1:3),disp(1:3) integer(int32) :: idx,i if (.not. allocated(this%stem)) then return end if idx = 0 original_position(1:3) = this%stem(1)%femdomain%Mesh%nodcoord(1,1:3) do i = 1, size(this%stem) if (this%stem(i)%femdomain%Mesh%empty() .eqv. .false.) then idx = idx + 1 call this%stem(idx)%rotate(& x=stem_angle_list(idx,1),& y=stem_angle_list(idx,2),& z=stem_angle_list(idx,3),reset=True) end if end do call this%update() disp = original_position(1:3) - this%stem(1)%femdomain%Mesh%nodcoord(1,1:3) call this%move(x=disp(1),y=disp(2),z=disp(3)) call this%update() end subroutine ! ##################################################################### ! ##################################################################### function get_stem_angle_list_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64),allocatable :: ret(:,:) integer(int32) :: idx,i ret = zeros(this%numStem(),3) if (.not. allocated(this%stem)) then return end if idx = 0 do i = 1, size(this%stem) if (this%stem(i)%femdomain%Mesh%empty() .eqv. .false.) then idx = idx + 1 ret(idx,1:3) = this%stem(idx)%getAngles() end if end do end function ! ##################################################################### ! ##################################################################### function height_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64) :: ret ret = this%z_max() - this%stem(1)%femdomain%z_min() end function ! ##################################################################### ! ##################################################################### function x_min_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64) :: ret integer(int32) :: i ret = this%stem(1)%femdomain%x_min() if (allocated(this%stem))then do i=1,size(this%stem) if (this%stem(i)%FEMDomain%mesh%empty()) cycle if (this%stem(i)%femdomain%x_min() <= ret)then ret = this%stem(i)%femdomain%x_min() endif enddo endif if (allocated(this%leaf))then do i=1,size(this%leaf) if (this%leaf(i)%FEMDomain%mesh%empty()) cycle if (this%leaf(i)%femdomain%x_min() <= ret)then ret = this%leaf(i)%femdomain%x_min() endif enddo endif if (allocated(this%root))then do i=1,size(this%root) if (this%root(i)%FEMDomain%mesh%empty()) cycle if (this%root(i)%femdomain%x_min() <= ret)then ret = this%root(i)%femdomain%x_min() endif enddo endif end function ! ##################################################################### ! ##################################################################### function x_max_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64) :: ret integer(int32) :: i ret = this%stem(1)%femdomain%x_max() if (allocated(this%stem))then do i=1,size(this%stem) if (this%stem(i)%FEMDomain%mesh%empty()) cycle if (this%stem(i)%femdomain%x_max() >= ret)then ret = this%stem(i)%femdomain%x_max() endif enddo endif if (allocated(this%leaf))then do i=1,size(this%leaf) if (this%leaf(i)%FEMDomain%mesh%empty()) cycle if (this%leaf(i)%femdomain%x_max() >= ret)then ret = this%leaf(i)%femdomain%x_max() endif enddo endif if (allocated(this%root))then do i=1,size(this%root) if (this%root(i)%FEMDomain%mesh%empty()) cycle if (this%root(i)%femdomain%x_max() >= ret)then ret = this%root(i)%femdomain%x_max() endif enddo endif end function ! ##################################################################### ! ##################################################################### function y_min_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64) :: ret integer(int32) :: i ret = this%stem(1)%femdomain%y_min() if (allocated(this%stem))then do i=1,size(this%stem) if (this%stem(i)%FEMDomain%mesh%empty()) cycle if (this%stem(i)%femdomain%y_min() <= ret)then ret = this%stem(i)%femdomain%y_min() endif enddo endif if (allocated(this%leaf))then do i=1,size(this%leaf) if (this%leaf(i)%FEMDomain%mesh%empty()) cycle if (this%leaf(i)%femdomain%y_min() <= ret)then ret = this%leaf(i)%femdomain%y_min() endif enddo endif if (allocated(this%root))then do i=1,size(this%root) if (this%root(i)%FEMDomain%mesh%empty()) cycle if (this%root(i)%femdomain%y_min() <= ret)then ret = this%root(i)%femdomain%y_min() endif enddo endif end function ! ##################################################################### ! ##################################################################### function y_max_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64) :: ret integer(int32) :: i ret = this%stem(1)%femdomain%y_max() if (allocated(this%stem))then do i=1,size(this%stem) if (this%stem(i)%FEMDomain%mesh%empty()) cycle if (this%stem(i)%femdomain%y_max() >= ret)then ret = this%stem(i)%femdomain%y_max() endif enddo endif if (allocated(this%leaf))then do i=1,size(this%leaf) if (this%leaf(i)%FEMDomain%mesh%empty()) cycle if (this%leaf(i)%femdomain%y_max() >= ret)then ret = this%leaf(i)%femdomain%y_max() endif enddo endif if (allocated(this%root))then do i=1,size(this%root) if (this%root(i)%FEMDomain%mesh%empty()) cycle if (this%root(i)%femdomain%y_max() >= ret)then ret = this%root(i)%femdomain%y_max() endif enddo endif end function ! ##################################################################### ! ##################################################################### function z_min_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64) :: ret integer(int32) :: i ret = this%stem(1)%femdomain%z_min() if (allocated(this%stem))then do i=1,size(this%stem) if (this%stem(i)%FEMDomain%mesh%empty()) cycle if (this%stem(i)%femdomain%z_min() <= ret)then ret = this%stem(i)%femdomain%z_min() endif enddo endif if (allocated(this%leaf))then do i=1,size(this%leaf) if (this%leaf(i)%FEMDomain%mesh%empty()) cycle if (this%leaf(i)%femdomain%z_min() <= ret)then ret = this%leaf(i)%femdomain%z_min() endif enddo endif if (allocated(this%root))then do i=1,size(this%root) if (this%root(i)%FEMDomain%mesh%empty()) cycle if (this%root(i)%femdomain%z_min() <= ret)then ret = this%root(i)%femdomain%z_min() endif enddo endif end function ! ##################################################################### ! ##################################################################### function z_max_Soybean(this) result(ret) class(Soybean_),intent(in) :: this real(real64) :: ret integer(int32) :: i ret = this%stem(1)%femdomain%z_max() if (allocated(this%stem))then do i=1,size(this%stem) if (this%stem(i)%FEMDomain%mesh%empty()) cycle if (this%stem(i)%femdomain%z_max() >= ret)then ret = this%stem(i)%femdomain%z_max() endif enddo endif if (allocated(this%leaf))then do i=1,size(this%leaf) if (this%leaf(i)%FEMDomain%mesh%empty()) cycle if (this%leaf(i)%femdomain%z_max() >= ret)then ret = this%leaf(i)%femdomain%z_max() endif enddo endif if (allocated(this%root))then do i=1,size(this%root) if (this%root(i)%FEMDomain%mesh%empty()) cycle if (this%root(i)%femdomain%z_max() >= ret)then ret = this%root(i)%femdomain%z_max() endif enddo endif end function ! ##################################################################### ! ##################################################################### subroutine init_as_seed_soybean(this,radius,division) class(Soybean_),intent(inout) :: this real(real64),intent(in) :: radius(1:3) integer(int32),intent(in) :: division(1:3) real(real64),allocatable :: x(:) real(real64) :: epsilon,cv_peti_angles(1:2),cv_peti_angles_z(1:2),cv_leaf_angles(1:2) type(Stem_) :: stem type(Leaf_) :: leaf type(Random_) :: random integer(int32) :: i,j ! 一旦地上部のみ this%stem_division = division call stem%init( & x_num=this%stem_division(1), & y_num=this%stem_division(2), & z_num=this%stem_division(3) & ) this%peti_width_ave = 0.0d0 this%peti_width_sig = 0.0d0 ! num_stem: 2, num_peti: 2 this%MaxStemNum = 4 ! num_leaf: 2 this%MaxLeafNum = 2 ! num_root: 1 this%MaxRootNum = 0 allocate (this%stem(this%MaxstemNum)) allocate (this%leaf(this%MaxLeafNum)) !allocate (this%root(obj%MaxrootNum)) allocate (this%stem2stem(this%MaxstemNum, this%MaxstemNum)) allocate (this%leaf2stem(this%MaxLeafNum, this%MaxStemNum)) !allocate (this%root2stem(this%MaxrootNum, this%MaxstemNum)) !allocate (this%root2root(this%MaxrootNum, this%MaxrootNum)) this%stem2stem(:,:) = 0 this%leaf2stem(:,:) = 0 !this%root2stem(:,:) = 0 !this%root2root(:,:) = 0 this%stem2stem(2, 1) = 1 this%leaf2stem(1:2, 1) = 1 !this%root2stem(1, 1) = 1 !this%root2root(:, :) = 0 this%ms_node = 2 allocate (this%NodeID_MainStem(this%ms_node)) this%NodeID_MainStem = [1,2] ! 胚軸の比率 this%ms_width = radius(2)*0.10d0 this%ms_length = radius(3)*0.50d0 epsilon = radius(2)*0.030d0 this%leaf_division = division do i = 1, this%ms_node this%stem(i) = stem this%stem(i)%stemID = 0 this%stem(i)%InterNodeID = i this%stem(i)%already_grown = .true. this%NodeID_MainStem(i) = i call this%stem(i)%resize( & x=this%ms_width, & y=this%ms_width, & z=this%ms_length/dble(this%ms_node) & ) if (i>1)then x = this%stem(i-1)%getCoordinate("B") - this%stem(i)%getCoordinate("A") call this%stem(i)%move( & x=x(1), & y=x(2), & z=x(3)-epsilon & ) endif call this%stem(i)%rotate(y=radian(-30.0d0)*dble(i-1)) !call obj%stem(i)%rotate( & ! x=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)), & ! y=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)), & ! z=radian(random%gauss(mu=obj%ms_angle_ave, sigma=obj%ms_angle_sig)) & ! ) end do call leaf%init(species=PF_SOYBEAN_CV, & width=radius(1),& length=radius(2),& thickness=radius(3),& x_num=this%leaf_division(1), & y_num=this%leaf_division(2), & z_num=this%leaf_division(3) & ) this%num_stem_node = this%ms_node this%num_leaf = 0 cv_peti_angles_z = [radian(-10.0d0),radian(10.0d0)] cv_peti_angles = [radian(80.0d0),radian(-80.0d0)] cv_leaf_angles = [radian(0.0d0),radian(180.0d0)] do i = 1, 2 ! 子葉につき複葉なし ! add peti this%num_stem_node = this%num_stem_node + 1 this%stem(this%num_stem_node) = stem this%stem(this%num_stem_node)%already_grown = .true. ! 胚軸葉柄サイズ call this%stem(this%num_stem_node)%resize( & x=radius(1)*0.050d0, & y=radius(2)*0.050d0, & z=radius(3)*0.10d0 & ) call this%stem(this%num_stem_node)%rotate( & x=cv_peti_angles(i), & y=0.0d0, & z=cv_peti_angles_z(i) & ) call this%stem(this%num_stem_node)%connect("=>", this%stem(1)) this%stem2stem(this%num_stem_node, 1) = 1 ! add leaves ! ?? !leaf_z_angles = linspace([0.0d0, 360.0d0], obj%max_num_leaf_per_petiole + 1) !do j = 1, obj%max_num_leaf_per_petiole ! leaf_z_angles(j) = radian(leaf_z_angles(j)) !end do !leaf_z_angles(:) = leaf_z_angles(:) + radian(random%random()*360.0d0) do j = 1, 1 !obj%max_num_leaf_per_petiole this%num_leaf = this%num_leaf + 1 this%leaf(this%num_leaf) = leaf this%leaf(this%num_leaf)%LeafID = j !y_val = random%gauss(mu=obj%leaf_thickness_ave(i), sigma=obj%leaf_thickness_sig(i)) !z_val = random%gauss(mu=obj%leaf_length_ave(i), sigma=obj%leaf_length_sig(i)) !x_val = random%gauss(mu=obj%leaf_width_ave(i), sigma=obj%leaf_width_sig(i)) this%leaf(this%num_leaf)%already_grown = .true. !call obj%leaf(obj%num_leaf)%move( & ! y=-y_val/2.0d0, & ! z=-z_val/2.0d0, & ! x=-x_val/2.0d0 & ! ) call this%leaf(this%num_leaf)%rotate( & x=cv_leaf_angles(i), & y=50.0d0, & z=0.0d0 & ) call this%leaf(this%num_leaf)%connect("=>", this%stem(this%num_stem_node)) this%leaf2stem(this%num_leaf, this%num_stem_node) = 1 end do end do call this%update() end subroutine ! ##################################################################### end module