init_th.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    init_th            ../engine/source/output/th/init_th.F
!||--- called by ------------------------------------------------------
!||    init_th0           ../engine/source/output/th/init_th0.F
!||--- calls      -----------------------------------------------------
!||    spmd_gather_int    ../engine/source/mpi/generic/spmd_gather_int.F
!||    spmd_gatherv_int   ../engine/source/mpi/generic/spmd_gatherv_int.F
!||    thcoq_count        ../engine/source/output/th/thcoq_count.F
!||    thnod_count        ../engine/source/output/th/thnod_count.F
!||    thnst_count        ../engine/source/output/th/thnst_count.F
!||    thpout_count       ../engine/source/output/th/thpout_count.F
!||    thquad_count       ../engine/source/output/th/thquad_count.F
!||    thres_count        ../engine/source/output/th/thres_count.F
!||    thsol_count        ../engine/source/output/th/thsol_count.F
!||    thsph_count        ../engine/source/output/th/thsph_count.F
!||    thtrus_count       ../engine/source/output/th/thtrus_count.F
!||--- uses       -----------------------------------------------------
!||    cluster_mod        ../engine/share/modules/cluster_mod.F
!||    elbufdef_mod       ../common_source/modules/mat_elem/elbufdef_mod.F90
!||    groupdef_mod       ../common_source/modules/groupdef_mod.F
!||    stack_mod          ../engine/share/modules/stack_mod.F
!||    th_mod             ../engine/share/modules/th_mod.F
!||====================================================================
        SUBROUTINE init_th(IPARG,ITHBUF,ELBUF_TAB,IGEO,IXR,
     .                     ITHGRP,NTHGRP2,ID,WEIGHT,SITHBUF)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE elbufdef_mod         
      USE cluster_mod        
      USE stack_mod
      USE groupdef_mod
      USE th_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "task_c.inc"
#include      "tabsiz_c.inc" 
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(IN) :: SITHBUF
      INTEGER MBUFFER, NPARTL,NTHGRP2
      INTEGER IPARG(NPARG,*),IGEO(NPROPGI,*),
     .   ithgrp(nithgr,*),ithbuf(sithbuf),ixr(nixr,*),weight(numnod)
      INTEGER, INTENT(in) :: ID
C     REAL
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,L,M,N,II,JJ,IP,NP,NN,NG,ITY,NEL,NFT,N1,N2,NPT,NRWA,
     .   jale,fsavmax,proc,nvar,iad,ityp,iadv,first,krbhol,iskn,nnod,eltype
      INTEGER :: MY_SIZE,TOTAL_INDEX_WA_SIZE,IJK
      INTEGER, DIMENSION(NTHGRP2+1) :: LOCAL_WA
      INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX_WA_ELTYPE_P0,INDEX_WA_SIZE_P0
      INTEGER, DIMENSION(:), ALLOCATABLE :: WA_INDEX_DIPLS
      TYPE(TH_COMM), DIMENSION(:), POINTER :: WA_COMM
      INTEGER, DIMENSION(:), POINTER :: WA_SIZE,TOTAL_WA_SIZE
      TYPE(th_proc_type), DIMENSION(:), POINTER :: ELTYPE_STRUCT 
      TYPE(th_wa_real), DIMENSION(:), POINTER :: WA_P0,WA
C=======================================================================
 
C-------------------------------------------------------
C    TH GROUP
C-------------------------------------------------------
 
 
!   -------------------------------------
!               SPRING ELEMENT
!   TH optimization for spring elements
!           local data on each proc:
!
!   N=                     1              2   
!                   ________________   ______ 
!                  /                \ /      \
!   proc=    1    |    a1  |   a2    |   b1   |
 
!   N=                          1        2       3 
!                   ________________   ______  ______ 
!                  /                \ /      \/      \
!   proc=    2    |    a3  |   a4    |  b3    |   c1  |
!
!   N=                 2       3 
!                   ______   ______ 
!                  /      \ /      \
!   proc=    3    |  b2    |   c2  |
!
!   local data are sent to PROC0 (WA_SPRING_P0):
!   N=               1    1   2      1     1   2    3      2    3
!                 | a1 | a2 | b1 ||| a3 | a4 | b3 | c1 ||| b2 | c2 |
!   local proc=           1      |||         2         |||    3
!
!   --> need to know where are the data in WA_SPRING_P0 and where the data must be 
!       written in the TH file
!       for this, the local index (INDEX_WA_ELTYPE) for each proc is sent to PROC0 (INDEX_WA_ELTYPE_P0)
!       in order to build the global index SPRING_STRUCT(I)%TH_ELM(:,:)
!       SPRING_STRUCT(I)%TH_ELM(:,1) = position in the buffer
!       SPRING_STRUCT(I)%TH_ELM(:,2) = N
!
!       the position of the first element in the TH file is added at the end of each chunk ax, bx, cx... 
!
 
!   proc=    1    1    2    2
!   N=1    | a1 | a2 | a3 | a4 |
!          |         |    |
!   pos= a1(NVAR+1)..|  a4(NVAR+1)
!                    a3(NVAR+1)
!
!   proc=    1    3    2 
!   N=2    | b1 | b2 | b3 |
!          |    |    |
!   pos= b1(NVAR+1)..|b3(NVAR+1)
!               b2(NVAR+1)
!
!   proc=     2    3   
!   N=3    | c1 | c2 |
!
!   -------------------------------------
        !   ----------------------------------
        
        !   allocation of local arrays
        ALLOCATE( index_wa_eltype(2*nthgrp2+1) )
        ALLOCATE( index_wa_size_p0(nspmd) )
        ALLOCATE( wa_index_dipls(nspmd) )
 
        DO eltype=1,9
            !   ELTYPE = 1 --> spring
            !   ELTYPE = 2 --> node
            !   ELTYPE = 3 --> sol
            !   ELTYPE = 4 --> quad
            !   ELTYPE = 5 --> shell/shell3n
            !   ELTYPE = 6 --> truss
            !   ELTYPE = 7 --> beam
            !   ELTYPE = 8 --> sph
            !   ELTYPE = 9 --> nstrand
            IF(eltype==1) THEN
                wa_comm=>wa_spring_comm
                wa_size=>wa_spring_size
                total_wa_size=>total_wa_spring_size           
                eltype_struct=>spring_struct
                wa=>wa_spring
                wa_p0=>wa_spring_p0
            ELSEIF(eltype==2) THEN
                wa_comm=>wa_nod_comm
                wa_size=>wa_nod_size
                total_wa_size=>total_wa_nod_size           
                eltype_struct=>nod_struct
                wa=>wa_nod
                wa_p0=>wa_nod_p0
            ELSEIF(eltype==3) THEN
                wa_comm=>wa_sol_comm
                wa_size=>wa_sol_size
                total_wa_size=>total_wa_sol_size           
                eltype_struct=>sol_struct
                wa=>wa_sol
                wa_p0=>wa_sol_p0
            ELSEIF(eltype==4) THEN
                wa_comm=>wa_quad_comm
                wa_size=>wa_quad_size
                total_wa_size=>total_wa_quad_size           
                eltype_struct=>quad_struct
                wa=>wa_quad
                wa_p0=>wa_quad_p0
            ELSEIF(eltype==5) THEN
                wa_comm=>wa_coq_comm
                wa_size=>wa_coq_size
                total_wa_size=>total_wa_coq_size           
                eltype_struct=>coq_struct
                wa=>wa_coq
                wa_p0=>wa_coq_p0
            ELSEIF(eltype==6) THEN
                wa_comm=>wa_trus_comm
                wa_size=>wa_trus_size
                total_wa_size=>total_wa_trus_size           
                eltype_struct=>trus_struct
                wa=>wa_trus
                wa_p0=>wa_trus_p0
            ELSEIF(eltype==7) THEN
                wa_comm=>wa_pout_comm
                wa_size=>wa_pout_size
                total_wa_size=>total_wa_pout_size           
                eltype_struct=>pout_struct
                wa=>wa_pout
                wa_p0=>wa_pout_p0
            ELSEIF(eltype==8) THEN
                wa_comm=>wa_sph_comm
                wa_size=>wa_sph_size
                total_wa_size=>total_wa_sph_size           
                eltype_struct=>sph_struct
                wa=>wa_sph
                wa_p0=>wa_sph_p0
            ELSEIF(eltype==9) THEN
                wa_comm=>wa_nst_comm
                wa_size=>wa_nst_size
                total_wa_size=>total_wa_nst_size           
                eltype_struct=>nst_struct
                wa=>wa_nst
                wa_p0=>wa_nst_p0
            ENDIF
 
            ALLOCATE( wa_comm(id)%TH_SIZE(nspmd) )
            ALLOCATE( wa_comm(id)%TH_DIPLS(nspmd) )
 
            wa_comm(id)%TH_SIZE(1:nspmd) = 0
            index_wa_eltype(1:2*nthgrp2+1) = 0
            index_wa_size_p0(1:nspmd) = 0
            wa_index_dipls(1:nspmd) = 0
 
            !   count the number of chunk and get the total size of WA_SPRING
            IF(eltype==1) THEN
                CALL thres_count(iparg,ithbuf,elbuf_tab,igeo,ixr,
     .                         ithgrp,nthgrp2,wa_size(id),index_wa_eltype,sithbuf)
            ELSEIF(eltype==2) THEN
                CALL thnod_count(ithgrp,nthgrp2,wa_size(id),index_wa_eltype,ithbuf,
     .                           weight,sithbuf)
            ELSEIF(eltype==3) THEN
                CALL thsol_count(nthgrp2 ,ithgrp,wa_size(id),index_wa_eltype,
     .                           iparg,ithbuf,sithbuf  )
            ELSEIF(eltype==4) THEN
                CALL thquad_count(nthgrp2 ,ithgrp,wa_size(id),index_wa_eltype,
     .                           iparg,ithbuf,sithbuf  )
            ELSEIF(eltype==5) THEN
                CALL thcoq_count(nthgrp2 ,ithgrp,wa_size(id),index_wa_eltype,
     .                           iparg,ithbuf,sithbuf  )
            ELSEIF(eltype==6) THEN
                CALL thtrus_count(nthgrp2,ithgrp,wa_size(id),index_wa_eltype,
     .                            iparg  ,ithbuf,sithbuf)
            ELSEIF(eltype==7) THEN
                CALL thpout_count(nthgrp2, ithgrp, wa_size(id),index_wa_eltype,
     .                            iparg  , ithbuf,sithbuf )
            ELSEIF(eltype==8) THEN
                CALL thsph_count(nthgrp2, ithgrp, wa_size(id),index_wa_eltype, 
     .                           iparg, ithbuf ,sithbuf)
            ELSEIF(eltype==9) THEN
                CALL thnst_count(nthgrp2, ithgrp, wa_size(id),index_wa_eltype,
     .                           iparg,ithbuf,sithbuf)
            ENDIF
 
            !   send the local size of index to PROC0
            my_size = index_wa_eltype(2*nthgrp2+1)
            IF(nspmd>1) THEN
                CALL spmd_gather_int(my_size,index_wa_size_p0,0,1,nspmd)
            ELSE
                index_wa_size_p0 = my_size
            ENDIF
 
    
            wa_comm(id)%TH_DIPLS(1:nspmd) = 0
            total_wa_size(id) = 0
            total_index_wa_size = 0
            IF(ispmd==0) THEN
                wa_index_dipls(1) = 0
                DO i=1,nspmd-1
                    wa_index_dipls(i+1) = wa_index_dipls(i) + index_wa_size_p0(i)
                    total_index_wa_size = total_index_wa_size + index_wa_size_p0(i)
                ENDDO
                total_index_wa_size = total_index_wa_size + index_wa_size_p0(nspmd)
            ENDIF
            !   allocation of INDEX_WA_ELTYPE_P0
            ALLOCATE( index_wa_eltype_p0(total_index_wa_size) )
    
            IF(nspmd>1) THEN
                !   send the local index to PROC0
                CALL spmd_gatherv_int(index_wa_eltype,index_wa_eltype_p0,0,my_size,total_index_wa_size,
     .                          index_wa_size_p0,wa_index_dipls)
 
                !   send the local size of WA_SPRING to PROC0
                CALL spmd_gather_int(wa_size(id),wa_comm(id)%TH_SIZE,0,1,nspmd)
            ELSE
                index_wa_eltype_p0 = index_wa_eltype
                wa_comm(id)%TH_SIZE(1) = wa_size(id)
            ENDIF
    
            IF(ispmd==0) THEN
                !   displacement for the gatherv comm and total size of WA_SPRING_P0
                wa_comm(id)%TH_DIPLS(1) = 0
                DO i=1,nspmd-1
                    wa_comm(id)%TH_DIPLS(i+1) = wa_comm(id)%TH_DIPLS(i) + wa_comm(id)%TH_SIZE(i)
                    total_wa_size(id) = total_wa_size(id) + wa_comm(id)%TH_SIZE(i)
                ENDDO
                total_wa_size(id) = total_wa_size(id) + wa_comm(id)%TH_SIZE(nspmd)
            ENDIF
 
            IF(ispmd==0) THEN
                !   allocation of SPRING_STRUCT + initialization
                ALLOCATE( eltype_struct(id)%TH_PROC(nspmd) )
                DO i=1,nspmd                
                    local_wa(1:nthgrp2+1) = 0
                    j = wa_index_dipls(i)
                    local_wa(1) = wa_comm(id)%TH_DIPLS(i)
                    !   index initialization
                    DO ijk=1,index_wa_size_p0(i)/2
                        n = index_wa_eltype_p0(2*ijk+j)
                        local_wa(n+1) = wa_comm(id)%TH_DIPLS(i) + index_wa_eltype_p0(2*ijk-1+j)
                    ENDDO
 
                    DO n=2,nthgrp2+1
                        IF(local_wa(n)==0) THEN
                            local_wa(n)=local_wa(n-1)
                        ENDIF
                    ENDDO
    
                    !   if PROC I must send its data to PROC0
                    IF(index_wa_size_p0(i)/2>0) THEN
                        !   count the number of N in order to reduce the size 
                        ijk = 0
                        DO n=2,nthgrp2+1
                            IF(local_wa(n)-local_wa(n-1)>0) THEN
                                ijk=ijk+1                  
                            ENDIF
                        ENDDO
                        ijk=ijk+1
                        !   allocation of %TH_ELM_SIZE 
                        eltype_struct(id)%TH_PROC(i)%TH_ELM_SIZE = ijk
                        ijk = eltype_struct(id)%TH_PROC(i)%TH_ELM_SIZE
                        ALLOCATE( eltype_struct(id)%TH_PROC(i)%TH_ELM(ijk,2) )
                        !   initialization of %TH_ELM_SIZE 
                        ijk = 0
                        DO n=2,nthgrp2+1
                            IF(local_wa(n)-local_wa(n-1)>0) THEN
                                ijk=ijk+1
                                eltype_struct(id)%TH_PROC(i)%TH_ELM(ijk,1) = local_wa(n-1)
                                eltype_struct(id)%TH_PROC(i)%TH_ELM(ijk,2) = n-1                        
                            ENDIF
                        ENDDO
                        ijk=ijk+1
                        eltype_struct(id)%TH_PROC(i)%TH_ELM(ijk,1) = local_wa(nthgrp2+1)
                        eltype_struct(id)%TH_PROC(i)%TH_ELM(ijk,2) = nthgrp2+1
                    ELSE
                    !   elseif PROC I do nothing : allocation to 0
                        eltype_struct(id)%TH_PROC(i)%TH_ELM_SIZE = 0
                        ALLOCATE( eltype_struct(id)%TH_PROC(i)%TH_ELM(0,0) )
                    ENDIF
                ENDDO
            ENDIF
 
            !   allocation of WA_SPRING and WA_SPRING_P0 (--> size=0 for every PROC except PROC0)
            ALLOCATE( wa(id)%WA_REAL(wa_size(id)) )
            ALLOCATE( wa_p0(id)%WA_REAL(total_wa_size(id)) )
            !   initialisation done : next element type
             DEALLOCATE( index_wa_eltype_p0 )
        ENDDO
        !   initialisation done
        DEALLOCATE( index_wa_eltype )
        DEALLOCATE( index_wa_size_p0 )
        DEALLOCATE( wa_index_dipls )
        !   ----------------------------------    
        RETURN
        END SUBROUTINE init_th