! copyright 2005, J. E. Akin, all rights reserved. ! Begin demo_select_lib.f (also see select_source_lib.f) ! NOTE: This is the set of programs that are valid for one example ! application. Each example is identified in its data file by the ! keyword "example" followed by a number, say nnn. Given nnn the ! corresponding files here are executed by the code in the ! select_source_lib.f using SELECT CASE features. Thus both ! libraries need to be edited when a new example is added to ! this source library. ! Only ELEM_SQ_MATRIX is always required by every example problem. ! It must be edited to contain the problem dependent source, or the ! include path to the problem dependent source. Then this library ! must be compiled and linked to the other archived executables. ! NOTE: Routines B_MATRIX_EX_nnn and E_MATRIX_EX_nnn are required only ! if the SCP error erstimator is invoked. (With nnn replaced with the ! three digit EXAMPLE number.) !============= Begin Files for EXAMPLE number nnn ============= SUBROUTINE DESCRIBE_EXAMPLE_nnn ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE nnn ***' END SUBROUTINE DESCRIBE_EXAMPLE_nnn FUNCTION GET_B_MATRIX_EX_nnn (DGH, XYZ) RESULT (B) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT B MATRIX FOR STRAIN OR GRADIENTS ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for LT_N, LT_FREE, & H (LT_N) IF NEEDED IMPLICIT NONE REAL (DP), INTENT(IN) :: DGH (N_SPACE, LT_N) REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP) :: B (N_R_B, LT_FREE) B = 0.d0 ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *,DGH (1, 1), XYZ (1), B (1, 1) ! STOP 'Edit GET_B_MATRIX_EX_nnn to use my_b_matrix_inc' STOP 'ERROR: NO SOURCE AT GET_B_MATRIX_EX_nnn' END FUNCTION GET_B_MATRIX_EX_nnn SUBROUTINE B_MATRIX_EX_nnn (DGH, XYZ, B) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT B MATRIX FOR STRAIN OR GRADIENTS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for LT_N, LT_FREE, & H (LT_N) IF NEEDED IMPLICIT NONE REAL (DP), INTENT(IN) :: DGH (N_SPACE, LT_N) REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: B (N_R_B, LT_FREE) B = 0.d0 ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, DGH (1, 1), XYZ (1), B (1, 1) STOP 'ERROR: NO SOURCE AT B_MATRIX_EX_nnn' END SUBROUTINE B_MATRIX_EX_nnn FUNCTION GET_E_MATRIX_EX_nnn (IE, XYZ) RESULT (E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP) :: E (N_R_B, N_R_B) E = 0.d0 ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ (1), E (1, 1) STOP 'ERROR: NO SOURCE AT GET_E_MATRIX_EX_nnn' END FUNCTION GET_E_MATRIX_EX_nnn SUBROUTINE E_MATRIX_EX_nnn (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) E = 0.d0 ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ (1), E (1, 1) STOP 'ERROR: NO SOURCE AT E_MATRIX_EX_nnn' END SUBROUTINE E_MATRIX_EX_nnn SUBROUTINE ELEM_SQ_EX_nnn (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) STOP 'ERROR: NO SOURCE AT ELEM_SQ_EX_nnn' END SUBROUTINE ELEM_SQ_EX_nnn SUBROUTINE MIXED_SQ_EX_nnn (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE MIXED_BC SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** MIXED_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) STOP 'ERROR: NO SOURCE AT MIXED_SQ_EX_nnn' END SUBROUTINE MIXED_SQ_EX_nnn SUBROUTINE ELEM_COL_EX_nnn (E, H_INTG, PRT_L_PT, PRT_MAT,& L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE OPTIONAL ELEMENT COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & XYZ (N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** ELEM_COL_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) STOP 'ERROR: NO SOURCE AT ELEM_COL_EX_nnn' END SUBROUTINE ELEM_COL_EX_nnn SUBROUTINE SEG_COL_EX_nnn (E, H_INTG, PRT_L_PT, PRT_MAT,& L_PT_PROP, IE, FLUX) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE FLUX SEGMENT COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Geometric_Properties Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! OPTIONAL FLUX VALUES IF BOUNDARY SEGMENT ELEMENT REAL(DP), INTENT(IN) :: FLUX (L_B_N, N_G_FLUX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & XYZ (N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** SEG_COL_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, FLUX STOP 'ERROR: NO SOURCE AT SEG_COL_EX_nnn' END SUBROUTINE SEG_COL_EX_nnn SUBROUTINE ELEM_POST_EX_nnn (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE, FLUX) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE DATA FOR ELEMENT POST-SOLUTION USE IN POST_PROCESS_ELEM ! IF THAT WAS NOT DONE IN ELEM_SQ_MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! OPTIONAL FLUX VALUES IF BOUNDARY SEGMENT ELEMENT REAL(DP), INTENT(IN) :: FLUX (L_B_N, N_G_FLUX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & XYZ (N_SPACE) REAL(DP) :: H_INTG (LT_N ), & B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2), BODY (N_SPACE) REAL(DP) :: DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** ELEM_POST_EX_nnn PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, FLUX STOP 'ERROR: NO SOURCE AT ELEM_POST_EX_nnn' END SUBROUTINE ELEM_POST_EX_nnn SUBROUTINE POST_PROCESS_ELEM_EX_nnn (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_nnn ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_ELEM_EX_nnn' END SUBROUTINE POST_PROCESS_ELEM_EX_nnn SUBROUTINE POST_PROCESS_MIXED_EX_nnn (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! MIXED SEGMENT POST-SOLUTION CALCULATIONS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, MIXEDENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_MIXED PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_MIXED_EX_nnn' END SUBROUTINE POST_PROCESS_MIXED_EX_nnn FUNCTION START_DOF_VALUE_EX_nnn (IG, XYZ) ! * * * * * * * * * * * * * * * * * * * * * * * * * * ! DEFINE STARTING VALUE OF PARAMETER IG IN TERMS OF ! COORDINATES OF THE NODE (FOR ITERATIVE SOLUTIONS) ! * * * * * * * * * * * * * * * * * * * * * * * * * * ! A PROBLEM DEPENDENT ROUTINE Use System_Constants ! For EXAMPLE IMPLICIT NONE INTEGER, INTENT(IN) :: IG ! local dof number REAL(DP), INTENT(IN) :: XYZ (N_SPACE) ! position REAL(DP) :: START_DOF_VALUE_EX_nnn ! result ! IG = LOCAL PARAMETER NUMBER AT NODE ! .................................................... ! ** PROBLEM DEPENDENT START STATEMENTS FOLLOW ** ! .................................................... START_DOF_VALUE_EX_nnn = 0.d0 ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *,'START_DOF_VALUE:', IG, XYZ STOP 'ERROR: NO SOURCE AT START_DOF_VALUE_EX_nnn' END FUNCTION START_DOF_VALUE_EX_nnn !SUBROUTINE GET_CONSTANT_E_nnn (IE, E) !b turned off 4/8/02 !! * * * * * * * * * * * * * * * * * * * * * * * * * * * * !! COMPUTE A CONSTANT CONSTITUTIVE MATRIX, E !! * * * * * * * * * * * * * * * * * * * * * * * * * * * * !Use System_Constants ! For EXAMPLE !Use Elem_Type_Data ! for: LT_N, LT_PARM, COORD (LT_N, N_SPACE), & ! ! DLH (LT_PARM, LT_N), H (LT_N), etc !Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: IE ! ELEMENT NUMBER ! REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) ! CONSTITUTIVE MATRIX !! suppress compiler warnings (touch is never true) ! IF ( TOUCH ) PRINT *, IE, E (1, 1) ! STOP 'ERROR: NO SOURCE AT GET_CONSTANT_E_nnn' ! !b STOP 'Edit GET_CONSTANT_E to use my_e_matrix_inc' !END SUBROUTINE GET_CONSTANT_E_nnn ! ============= End Files for EXAMPLE number nnn ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 101 ============= SUBROUTINE DESCRIBE_EXAMPLE_101 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *,'*** DESCRIPTIONS OF EXAMPLE 101 ***' PRINT *,'Heat conduction through, convection from a bar:' PRINT *,'K*A*U,XX - h*P*(U-U_ext) = 0, U(0)=U_0, dU/dx(L)=0' PRINT *,'For globally constant data the analytic solution is:' PRINT *,'U(x) = U_ext - (U_0-U_ext) * Cosh [m*(L-x)] / Cosh [mL]' PRINT *,'Reaction is equal and opposite to the total convection ' PRINT *,'loss = h_e*P_e*(U_0-U_ext)*Sinh(m*L)/(m*Cosh_mL)' PRINT *,'m^2 = h_e*P_e/(K_e*A_e)' PRINT *,'U_ext = GET_REAL_MISC (1) for external temperature' PRINT *,'L = GET_REAL_MISC (2) for exact length' PRINT *,'U_0 = GET_REAL_MISC (3) for essential bc at x = 0' PRINT *,'K_e = GET_REAL_LP (1) thermal conductivity' PRINT *,'A_e = GET_REAL_LP (2) area of bar' PRINT *,'h_e = GET_REAL_LP (3) convection coefficent' PRINT *,'P_e = GET_REAL_LP (4) perimeter of area A_e' PRINT *,' ' PRINT *,'OR' PRINT *,'' PRINT *,'Structural pile (axial bar) in an elastic foundation:' PRINT *,'E*A*U,XX - k*P*U = 0, U(0)=U_0, dU/dx(L)=0' PRINT *,'For globally constant data the analytic solution is:' PRINT *,'U(x) = U_0 * Cosh [m*(L-x)] / Cosh [mL]' PRINT *,'Soil reaction is equal and opposite to total load:' PRINT *,'Soil = k_e*P_e*U_0*Sinh(m*L)/(m*Cosh_mL)' PRINT *,'m^2 = k_e*P_e/(E_e*A_e)' PRINT *,'Miscellaneous data used ONLY for analytic solution:' PRINT *,'U_ext = GET_REAL_MISC (1) external soil settlement, 0' PRINT *,'L = GET_REAL_MISC (2) for exact length' PRINT *,'U_0 = GET_REAL_MISC (3) for essential bc at x = 0' PRINT *,'Real FE problem properties are:' PRINT *,'E_e = GET_REAL_LP (1) elastic modulus, kN/cm^2' PRINT *,'A_e = GET_REAL_LP (2) area of bar, cm^2' PRINT *,'k_e = GET_REAL_LP (3) foundation stiffness, kN/cm^2' PRINT *,'P_e = GET_REAL_LP (4) perimeter of area A_e, cm' END SUBROUTINE DESCRIBE_EXAMPLE_101 SUBROUTINE ELEM_SQ_EX_101 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! ! Combined heat conduction through, convection from a bar: ! K*A*U,XX - h*P*(U-U_ext) = 0, U(0)=U_0, dU/dx(L)=0 ! For globally constant data the analytic soultion is: ! U(x) = U_ext - (U_0-U_ext) * Cosh [m*(L-x)] / Cosh [mL] ! Reaction is equal and opposite to the total convection ! loss = h_e*P_e*(U_0-U_ext)*Sinh(m*L)/(m*Cosh_mL) ! m^2 = h_e*P_e/(K_e*A_e) ! U_ext = GET_REAL_MISC (1) ! for external reference temperature ! L = GET_REAL_MISC (2) ! for exact length ! U_0 = GET_REAL_MISC (3) ! for essential bc at x = 0 ! K_e = GET_REAL_LP (1) ! thermal conductivity ! A_e = GET_REAL_LP (2) ! area of bar ! h_e = GET_REAL_LP (3) ! convection coefficent on perimeter ! P_e = GET_REAL_LP (4) ! perimeter of area A_e REAL(DP) :: DL, DX_DR ! Length, Jacobian REAL(DP) :: K_e, A_e, h_e, P_e, U_ext ! properties INTEGER :: IQ ! Loops IF ( DEBUG_PROPERTY ) PRINT *, 'Entering ELEM_SQ_EX_101 ' DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL / 2. ! CONSTANT JACOBIAN U_ext = GET_REAL_MISC (1) ! external temperature K_e = GET_REAL_LP (1) ! thermal conductivity A_e = GET_REAL_LP (2) ! area of bar h_e = GET_REAL_LP (3) ! convection coefficent on perimeter P_e = GET_REAL_LP (4) ! perimeter of area A_e E = A_e * K_e ! constitutive CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !b ! S, C, H_INTG already zeroed DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL DERIVATIVES DLH = GET_DLH_AT_QP (IQ) DGH = DLH / DX_DR ! CONVECTION SOURCE C = C + h_e * P_e * U_ext * H * WT (IQ) * DX_DR ! SQUARE MATRIX, CONDUCTION & CONVECTION S = S + ( K_e * A_e * MATMUL (TRANSPOSE(DGH), DGH) & + h_e * P_e * OUTER_PRODUCT (H, H) ) * WT (IQ) * DX_DR ! INTEGRATING FOR CONVECTION LOSS, POST PROCESSING H_INTG = H_INTG + h_e * P_e * H * WT (IQ) * DX_DR ! SAVE FOR FLUX AVERAGING OR POST PROCESSING, B == DGH CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) !b !b IF ( N_FILE1 > 0) WRITE (N_FILE1) DGH ! FOR GRADIENT POST_PROC END DO ! QUADRATURE IF ( N_FILE2 > 0) WRITE (N_FILE2) H_INTG ! FOR HEAT LOSS ! End of application dependent code ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_101 SUBROUTINE POST_PROCESS_ELEM_EX_101 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_101 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! ! Combined heat conduction through, convection from a bar: ! K*A*U,XX - h*P*(U-U_ext) = 0, U(0)=U_0, dU/dx(L)=0 ! For globally constant data the analytic soultion is: ! U(x) = U_ext - (U_0-U_ext) * Cosh [m*(L-x)] / Cosh [mL] ! Reaction is equal and opposite to the total convection ! loss = h_e*P_e*(U_0-U_ext)*Sinh(m*L)/(m*Cosh_mL) ! m^2 = h_e*P_e/(K_e*A_e) ! U_ext = GET_REAL_MISC (1) ! for external reference temperature ! L = GET_REAL_MISC (2) ! for exact length ! U_0 = GET_REAL_MISC (3) ! for essential bc at x = 0 ! K_e = GET_REAL_LP (1) ! thermal conductivity ! A_e = GET_REAL_LP (2) ! area of bar ! h_e = GET_REAL_LP (3) ! convection coefficent on perimeter ! P_e = GET_REAL_LP (4) ! perimeter of area A_e REAL(DP) :: EXACT, GRAD, VALUE, X_IQ, P_IQ (1) REAL(DP) :: DL, DX_DR REAL(DP) :: K_e, A_e, h_e, P_e ! properties REAL(DP), SAVE :: Q_E_LOSS, TOTAL_LOSS, EXACT_LOSS ! convection losses REAL(DP), SAVE :: L, m, COSH_ML, U_0, U_ext ! in exact sol INTEGER :: IQ, N_IP ! loops IF ( DEBUG_PROPERTY ) PRINT *, 'Entering POST_PROCESS_ELEM_EX_101 ' K_e = GET_REAL_LP (1) ! thermal conductivity A_e = GET_REAL_LP (2) ! area of bar h_e = GET_REAL_LP (3) ! convection coefficent on perimeter P_e = GET_REAL_LP (4) ! perimeter of area A_e IF ( IE == 1 ) THEN !--> WRITE GRADIENT HEADINGS WRITE (6, 10) 10 FORMAT ( /, '** ELEMENT GAUSS POINT RESULTS **',/, & & 'ELEMENT X EXACT FEA ', & & 'GRADIENT FE_GRADIENT' ) TOTAL_LOSS = 0.d0 ! INITIALIZE m = sqrt (h_e*P_e/(K_e*A_e)) ! for exact sol U_ext = GET_REAL_MISC (1) ! external ref temp L = GET_REAL_MISC (2) ! for exact U_0 = GET_REAL_MISC (3) ! essential bc at x = 0 COSH_ML = COSH (m*L) ! for exact END IF DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL / 2. ! CONSTANT JACOBIAN ! GET RESULTS AT FIRST NODE OF ELEMENT P_IQ (1) = -1.d0 ; X_IQ = COORD (1, 1) ! First node CALL SCALAR_SHAPES (P_IQ (1), H) ! shapes VALUE = DOT_PRODUCT ( H, D) ! fe value EXACT = U_ext + (U_0-U_ext)*COSH (m*(L-X_IQ)) / COSH_ML ! exact value CALL SCALAR_DERIVS (P_IQ (1), DLH) ! local grad DGH = DLH / DX_DR ! global gradient STRESS = MATMUL (DGH, D) ! FE GRADIENT GRAD = -(U_0-U_ext)*m*SINH (m*(L-X_IQ)) / COSH_ML ! exact grad WRITE (6, 11) IE, x_iq, exact, value, grad, STRESS (1) !b 11 FORMAT (I6, 2X, f6.3, 4(2x, 1PE12.5)) 11 FORMAT (I3, 1X, g9.4, 4(2x, 1PE12.5)) CALL READ_FLUX_POINT_COUNT (N_IP) !b !--> LOOP OVER QUADRATURE POINTS (ISOPARAMETRIC ELEMENT) !b DO IQ = 1, LT_QP DO IQ = 1, N_IP !b H = GET_H_AT_QP (IQ) ! shapes X_IQ = DOT_PRODUCT ( H, COORD (1:LT_N, 1)) ! x point VALUE = DOT_PRODUCT ( H, D) ! fe value EXACT = U_ext + (U_0-U_ext)*COSH(m*(L-X_IQ)) / COSH_ML ! exact value ! ---> CALCULATE GRADIENT, STRESS = DGH*D !b READ (N_FILE1) DGH ! Gradient matrix CALL READ_FLUX_POINT_DATA (XYZ, E, DGH) ! B=DGH ! Gradient matrix STRESS = MATMUL (DGH, D) ! FE GRADIENT GRAD = -(U_0-U_ext)*m*SINH (m*(L-X_IQ)) / COSH_ML ! exact grad WRITE (6, 11) IE, x_iq, exact, value, grad, STRESS (1) END DO ! GET RESULTS AT LAST NODE OF ELEMENT P_IQ (1) = 1.d0 ; X_IQ = COORD (LT_N, 1) ! Last node CALL SCALAR_SHAPES (P_IQ (1), H) ! shapes VALUE = DOT_PRODUCT ( H, D) ! fe value EXACT = U_ext + (U_0-U_ext)*COSH (m*(L-X_IQ)) / COSH_ML ! exact value CALL SCALAR_DERIVS (P_IQ (1), DLH) ! local grad DGH = DLH / DX_DR ! global gradient STRESS = MATMUL (DGH, D) ! FE GRADIENT GRAD = -(U_0-U_ext)*m*SINH (m*(L-X_IQ)) / COSH_ML ! exact grad WRITE (6, 11) IE, x_iq, exact, value, grad, STRESS (1) ! GET CONVECTIVE HEAT LOSS IF ( N_FILE2 > 0 ) THEN READ (N_FILE2) H_INTG Q_E_LOSS = DOT_PRODUCT ((D-U_ext), H_INTG) ! Elem loss WRITE (6, *) 'ELEMENT CONVECTION HEAT LOSS = ', Q_E_LOSS TOTAL_LOSS = TOTAL_LOSS + Q_E_LOSS IF ( IE == N_ELEMS ) THEN WRITE (6, *) 'TOTAL HEAT LOSS = ', TOTAL_LOSS EXACT_LOSS = H_e*P_e*(U_0-U_ext)*Sinh(m*L)/(m*Cosh_mL) WRITE (6, *) 'EXACT HEAT LOSS = ', EXACT_LOSS END IF ! LAST ELEMENT END IF ! LOSS DESIRED ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_101 ! =============== End Files for EXAMPLE number 101 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 102 ============= SUBROUTINE DESCRIBE_EXAMPLE_102 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 102 ***' PRINT *,'APPLICATION: LINEAR SLIDER BEARING' PRINT *,'[P,x h^3 / 6 nu],x = [U h],x + h,t' PRINT *,'UNKNOWN IS FLUID PRESSURE, P' PRINT *,'N_SPACE = 1, NOD_PER_EL = 2, N_G_DOF = 1' PRINT *,'N_EL_FRE = 2, MISC_FL = 2' PRINT *,'FLT_MISC(1) = VISCOSITY nu, FLT_MISC(2) = VELOCITY U' PRINT *,'EL_PROP(1) OR PRT_L_PT(K,1) = FILM THICKNESS, h' PRINT *,'EL_PROP(2) OR PRT_L_PT(K,2) = FILM SQUEEZE, h,t' END SUBROUTINE DESCRIBE_EXAMPLE_102 SUBROUTINE ELEM_SQ_EX_102 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! APPLICATION: LINEAR SLIDER BEARING, Example 102 ! Equation: [P,x h^3 / 6 nu],x = [U h],x + h,t ! N_SPACE = 1, NOD_PER_EL = 2, N_G_DOF = 1, N_EL_FRE = 2, ! MISC_FL = 2, either el_real or pt_real = 0, 1, or 2 ! GET_REAL_MISC (1) = VISCOSITY, GET_REAL_MISC (2) = VELOCITY ! GET_REAL_LP (1) OR PRT_L_PT (K,1) = FILM THICKNESS ! GET_REAL_LP (2) OR PRT_L_PT (K,2) = FILM SQUEEZE INTEGER, SAVE :: KALL = 1 REAL (DP), SAVE :: VIS, VEL, DL REAL (DP) :: THICK, CONST, SQUEEZE IF ( KALL == 1 ) THEN ! GET GLOBAL REAL CONSTANTS KALL = 0 VIS = GET_REAL_MISC (1) ; VEL = GET_REAL_MISC (2) END IF ! FIRST CALL !--> DEFINE ELEMENT LENGTH AND ELEMENT THICKNESS DL = COORD (2, 1) - COORD (1, 1) THICK = 0.d0 IF ( EL_REAL > 0 ) THICK = GET_REAL_LP (1) IF ( EL_REAL > 1 ) SQUEEZE = GET_REAL_LP (2) ! CHECK FOR ALTERNATE AVERAGE NODE THICKNESS IF ( THICK == 0.d0 ) THEN ! USE NODAL PROPERTY IF ( N_NP_FLO > 0 ) THEN ! DATA EXISTS THICK = 0.5d0 * (PRT_L_PT (1, 1) + PRT_L_PT (2, 1) ) SQUEEZE = 0.5d0 * (PRT_L_PT (1, 2) + PRT_L_PT (2, 2) ) ELSE STOP 'NO SLIDER BEARING THICKNESS DATA' END IF END IF ! NODAL THICKNESS DATA !--> GENERATE ELEMENT SQUARE MATRIX & COLUMN MATRIX CONST = THICK**3 / (6.0_DP * VIS * DL) S (1, 1) = CONST ; S (2, 2) = CONST S (1, 2) = -CONST ; S (2, 1) = -CONST C (1) = VEL * THICK + DL * SQUEEZE *0.5d0 !B check sign C (2) = -VEL * THICK + DL * SQUEEZE *0.5d0 !--> GENERATE DATA FOR LOAD CALCULATIONS AND STORE H_INTG (1) = 0.5_DP * DL ; H_INTG (2) = 0.5_DP * DL IF ( N_FILE1 > 0 ) WRITE (N_FILE1) H_INTG ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_102 SUBROUTINE POST_PROCESS_ELEM_EX_102 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_102 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! Define any new array or variable types, then give statements !APPLICATION: LINEAR SLIDER BEARING ! N_SPACE = 1, NOD_PER_EL = 2, N_G_DOF = 1 ! N_EL_FRE = 2, MISC_FL = 2 INTEGER, SAVE :: KALL = 1 REAL(DP), SAVE :: FORCE, TOTAL = 0.0_DP IF (KALL == 1) THEN !--> PRINT TITLES ON THE FIRST CALL KALL = 0 ; WRITE (6, 5) 5 FORMAT (/, '*** E L E M E N T L O A D S ***',/, & 'ELEMENT LOAD TOTAL') ENDIF !--> CALCULATE LOADS ON THE ELEMENTS, F = H_INTG*D READ (N_FILE1) H_INTG FORCE = DOT_PRODUCT (H_INTG, D) TOTAL = TOTAL + FORCE WRITE (6, 10) IE, FORCE, TOTAL 10 FORMAT (I5, 1PE16.5, 3X, 1PE16.5) ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_102 ! ============= End Files for EXAMPLE number 102 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 103 ============= SUBROUTINE DESCRIBE_EXAMPLE_103 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 103 ***' PRINT *, 'Least squares solution of dy/dx + A y = F with y(0) = 0' PRINT *, 'Analytically integrated linear line element' PRINT *, 'A, F are misc real properties 1, 2 respectively' PRINT *, 'Exact solution: y(x) = (1 - e (-Ax)) * F / A' END SUBROUTINE DESCRIBE_EXAMPLE_103 SUBROUTINE ELEM_SQ_EX_103 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays !b REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & !b AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) !b REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & !b STRESS (N_R_B + 2) !b REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & !b DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! APPLICATION: LEAST SQUARES SOLUTION OF Y' + A * Y = F ! N_SPACE = 1, NOD_PER_EL = 2, N_G_DOF = 1 REAL(DP), SAVE :: A, F, DL ! DL = LENGTH OF ELEMENT ! RECOVER MISC PROBLEM COEFFICIENTS, A AND F (ON FIRST CALL) IF ( IE == 1 ) THEN ! Get coeffients A = GET_REAL_MISC (1) ; F = GET_REAL_MISC (2) END IF DL = COORD (2, 1) - COORD (1, 1) S (1, 1) = (3.d0 - 3.d0 * A * DL + A * A * DL * DL) / 3.d0 / DL S (2, 2) = (3.d0 + 3.d0 * A * DL + A * A * DL * DL) / 3.d0 / DL S (1, 2) = (A * A * DL * DL - 6.d0) / 6.d0 / DL S (2, 1) = S (1, 2) C (1) = 0.5d0 * F * (A * DL - 2.d0) C (2) = 0.5d0 * F * (A * DL + 2.d0) !b ! suppress compiler warnings (touch is never true) !b IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & !b DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & !b PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_103 SUBROUTINE POST_PROCESS_ELEM_EX_103 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_103 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_ELEM_EX_103' END SUBROUTINE POST_PROCESS_ELEM_EX_103 ! ============= End Files for EXAMPLE number 103 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 104 ============= SUBROUTINE DESCRIBE_EXAMPLE_104 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 104 ***' PRINT *, 'Solution of the ODE u" + u + x = 0 for x in ]0,1[ ' PRINT *, 'with various boundary conditions, by Galerkin method.' PRINT *, 'Optional source to post-process invoked if keywords "post_1"' PRINT *, 'and/or "post_2" appear in the keywords control for' PRINT *, 'gradient comparisons and solution norms' END SUBROUTINE DESCRIBE_EXAMPLE_104 SUBROUTINE ELEM_SQ_EX_104 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! NOTE: IS_ELEMENT SHOULD BE TRUE HERE ! .............................................................. ! Define any new array or variable types, then give statements ! ! APPLICATION DEPENDENT Galerkin MWR FOR ODE ! U,XX + U + X = 0, with boundary conditions like ! U(0)=0=U(1), so U = Sin(x)/Sin(1) - x or ! U(0)=0,U'(1)=0, so U = Sin(x)/Cos(1) - x etc REAL(DP) :: DL, DX_DR ! Length, Jacobian REAL(DP) :: NORM_SQ (LT_FREE, LT_FREE) ! elem norm INTEGER :: IQ ! Loops DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH IF ( DL < 0.d0 ) THEN PRINT *,'WARNING: CORRECTED NEGATIVE LENGTH ELEMENT ', THIS_EL N_WARN = N_WARN + 1 ; DL = ABS (DL) END IF DX_DR = DL / 2. ! CONSTANT JACOBIAN E = 1.d0 ! CONSTANT E NORM_SQ = 0.d0 ! S, C already zeroed IF ( U_FLUX > 0 ) WRITE (U_FLUX) LT_QP ! for SCP or post-process DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL DERIVATIVES, B = DGH DLH = GET_DLH_AT_QP (IQ) DGH = DLH / DX_DR C = C + H * XYZ (1) * WT (IQ) * DX_DR ! SOURCE VECTOR ! SQUARE MATRIX S = S + ( MATMUL (TRANSPOSE(DGH), DGH) & - OUTER_PRODUCT (H, H) ) * WT (IQ) * DX_DR ! NORM MATRIX NORM_SQ = NORM_SQ + ( MATMUL (TRANSPOSE(DGH), DGH) & + OUTER_PRODUCT (H, H) ) * WT (IQ) * DX_DR IF ( U_FLUX > 0 ) WRITE (U_FLUX) XYZ, E, DGH ! for SCP or post-proc END DO ! QUADRATURE IF ( N_FILE2 > 0) WRITE (N_FILE2) NORM_SQ ! FOR H_1_NORM POST_PROC ! End of application dependent code ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_104 SUBROUTINE POST_PROCESS_ELEM_EX_104 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_104 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! ! APPLICATION DEPENDENT Galerkin MWR FOR ODE ! U,XX + U + X = 0, U(0)=0=U(1), U = Sin(x)/Sin(1) - x REAL(DP) :: EXACT, GRAD, VALUE, X_IQ, P_IQ (1) REAL(DP) :: DL, DX_DR REAL(DP) :: NORM_SQ (LT_FREE, LT_FREE) ! elem norm matrix REAL(DP), SAVE :: H_1_ELEM, H_1_TOTAL = 0.d0 ! elem norms INTEGER :: IQ ! Do not duplicate exact flux results if given elsewhere !b IF ( N_FILE1 > 0 .AND. .NOT. USE_EXACT_FLUX ) THEN ! GET GRADIENTS IF ( N_FILE1 > 0 ) THEN ! GET GRADIENTS IF ( IE == 1 ) THEN !--> WRITE GRADIENT HEADINGS IF ( EXACT_CASE /= 9 .AND. EXACT_CASE /= 10 ) THEN PRINT *, 'WARNING: POST_PROCESS_ELEM_EX_104 "post_1" INVALID' PRINT *, 'EXCEPT FOR EXACT_CASE = 9 AND 10' N_WARN = N_WARN + 1 END IF WRITE (6, 10) 10 FORMAT ( /, '** ELEMENT FLUX RESULTS **',/, & & 'ELEMENT X EXACT FEA ', & & 'GRADIENT FE_GRADIENT' ) H_1_TOTAL = 0.d0 ! INITIALIZE END IF DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL / 2. ! CONSTANT JACOBIAN ! GET RESULTS AT FIRST NODE OF ELEMENT P_IQ (1) = -1.d0 ; X_IQ = COORD (1, 1) ! First node CALL SCALAR_SHAPES (P_IQ (1), H) ! shapes CALL SCALAR_DERIVS (P_IQ (1), DLH) ! local grad VALUE = DOT_PRODUCT ( H, D) ! fe value DGH = DLH / DX_DR ! physical gradient STRESS (1) = DOT_PRODUCT (DGH(1,1:LT_N), D(1:LT_N)) ! FE GRADIENT SELECT CASE (EXACT_CASE) CASE (9) exact = sin (x_iq) / sin (1.d0) - x_iq grad = cos (x_iq) / sin (1.d0) - 1.d0 CASE (10) exact = sin (x_iq) / cos (1.d0) - x_iq grad = cos (x_iq) / cos (1.d0) - 1.d0 CASE DEFAULT ; exact = 0.d0 ; grad = 0.d0 END SELECT WRITE (6, 11) IE, x_iq, exact, value, grad, STRESS (1) 11 FORMAT (I6, 2X, f6.3, 4(2x, 1PE12.5)) IF ( U_FLUX > 0 ) THEN READ (U_FLUX) LT_QP !--> LOOP OVER QUADRATURE POINTS (ISOPARAMETRIC ELEMENT) DO IQ = 1, LT_QP H = GET_H_AT_QP (IQ) ! shapes X_IQ = DOT_PRODUCT ( H, COORD (1:LT_N, 1)) ! x point VALUE = DOT_PRODUCT ( H, D) ! fe value ! ---> CALCULATE GRADIENT, STRESS = DGH*D READ (U_FLUX) XYZ, E, DGH STRESS (1) = DOT_PRODUCT (DGH(1,1:LT_N), D(1:LT_N)) ! FE GRAD SELECT CASE (EXACT_CASE) CASE (9) exact = sin (x_iq) / sin (1.d0) - x_iq grad = cos (x_iq) / sin (1.d0) - 1.d0 CASE (10) exact = sin (x_iq) / cos (1.d0) - x_iq grad = cos (x_iq) / cos (1.d0) - 1.d0 CASE DEFAULT ; exact = 0.d0 ; grad = 0.d0 END SELECT WRITE (6, 11) IE, x_iq, exact, value, grad, STRESS (1) END DO END IF ! saved qp ! GET RESULTS AT LAST NODE OF ELEMENT P_IQ (1) = 1.d0 ; X_IQ = COORD (LT_N, 1) ! Last node CALL SCALAR_SHAPES (P_IQ (1), H) ! shapes CALL SCALAR_DERIVS (P_IQ (1), DLH) ! local grad VALUE = DOT_PRODUCT ( H, D) ! fe value DGH = DLH / DX_DR ! physical gradient STRESS (1) = DOT_PRODUCT (DGH(1,1:LT_N), D(1:LT_N)) ! FE GRAD SELECT CASE (EXACT_CASE) CASE (9) exact = sin (x_iq) / sin (1.d0) - x_iq grad = cos (x_iq) / sin (1.d0) - 1.d0 CASE (10) exact = sin (x_iq) / cos (1.d0) - x_iq grad = cos (x_iq) / cos (1.d0) - 1.d0 CASE DEFAULT ; exact = 0.d0 ; grad = 0.d0 END SELECT WRITE (6, 11) IE, x_iq, exact, value, grad, STRESS (1) END IF ! gradients ! GET NORM DATA IF ( N_FILE2 > 0) THEN READ (N_FILE2) NORM_SQ ! FOR H_1_NORM POST_PROC H_1_ELEM = DOT_PRODUCT (D, (MATMUL(NORM_SQ, D))) ! Elem value WRITE (6, *) 'SQUARE OF ELEMENT H_1 NORM = ', H_1_ELEM H_1_TOTAL = H_1_TOTAL + H_1_ELEM IF ( IE == N_ELEMS ) WRITE (6, *) & 'SQUARE OF TOTAL H_1 NORM = ', H_1_TOTAL END IF ! NORMS DESIRED ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_104 ! ============= End Files for EXAMPLE number 104 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 105 ============= SUBROUTINE DESCRIBE_EXAMPLE_105 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 105 ***' PRINT *, 'U" + Q(x) = 0, Usually with U(0)=0=U(1)' PRINT *, 'Q = X^L gives U(x) = (x-x^(L+2))/((L+1)(L+2))' PRINT *, 'L is first misc integer property. This is EXACT_CASE 11' PRINT *, 'If constant in elem Q is first real property.' PRINT *, 'Q_STEP = 1 for X<=1/2 else = 0 gives exact' PRINT *, 'U = X(3-4X)/8, X <= 1/2, else U = (1-X)/8, EXACT_CASE = 14' END SUBROUTINE DESCRIBE_EXAMPLE_105 SUBROUTINE ELEM_SQ_EX_105 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_SOURCE IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! NOTE: IS_ELEMENT SHOULD BE TRUE HERE ! .............................................................. ! Define any new array or variable types, then give statements ! ! APPLICATION DEPENDENT Galerkin MWR FOR ODE ! U,XX + Q = 0, U(0)=0=U(1) with Q in data file or ! Q(X) given by SELECT_EXACT_SOURCE (defaults to my_source_inc) REAL(DP) :: DL, DX_DR ! Length, Jacobian REAL(DP) :: SOURCE ! Q source term !b REAL(DP) :: NORM_SQ (LT_FREE, LT_FREE) ! elem norm INTEGER :: IQ, L ! Loops, optional DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL / 2. ! CONSTANT JACOBIAN ! SET CONSTANT PROPERTIES SOURCE = 0.d0 ; L = 0 ! DEFAULTS IF ( EL_REAL > 0 ) SOURCE = GET_REAL_LP (1) ! FOR Q CONST IF ( INTEGERS > 0 ) L = GET_INTEGER_MISC (1) ! FOR Q=X^L E(1, 1) = 1 ! identity matrix !b NORM_SQ = 0.d0 ! S, C already zeroed CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !b DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL DERIVATIVES, B = DGH DLH = GET_DLH_AT_QP (IQ) DGH = DLH / DX_DR ! Variable source Q(X) ? IF ( INTEGERS > 0 ) SOURCE = XYZ (1) **L ! Q = X^L ! Override via EXACT_CASE value or my_source_inc IF ( USE_EXACT_SOURCE ) CALL SELECT_EXACT_SOURCE (XYZ, SOURCE) ! RESULTANT SOURCE VECTOR C = C + SOURCE * H * WT (IQ) * DX_DR ! SQUARE MATRIX S = S + MATMUL (TRANSPOSE(DGH), DGH) * WT (IQ) * DX_DR !b ! NORM MATRIX !b NORM_SQ = NORM_SQ + ( MATMUL (TRANSPOSE(DGH), DGH) & !b + OUTER_PRODUCT (H, H) ) * WT (IQ) * DX_DR CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) !b END DO ! QUADRATURE !b IF ( N_FILE2 > 0) WRITE (N_FILE2) NORM_SQ ! FOR H_1_NORM POST_PROC ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_105 SUBROUTINE POST_PROCESS_ELEM_EX_105 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_105 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_ELEM_EX_105' END SUBROUTINE POST_PROCESS_ELEM_EX_105 ! ============= End Files for EXAMPLE number 105 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 106 ============= SUBROUTINE DESCRIBE_EXAMPLE_106 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 106 ***' PRINT *, "Y'' - 2XY'/(X^2+1) + 2Y/(X^2+1) = (X^2+1), Fausett p. 482" PRINT *, "An unsymmetric Galerkin solution" PRINT *, "Y(0)=2, Y(1)=5/3, Y=X^4/6 - 3X^2/2 + X + 2, EXACT_CASE 15" PRINT *, "Y(0)=1, Y'(1)+Y(1)=0, Y=(X^4 -3X^2 -X +6)/6, EXACT_CASE 16" PRINT *, "Y'(0)+Y(0)=0, Y'(1)-Y(1)=3, Y=X^4/6 +3X^2/2 +X -1, EXACT_CASE 17" PRINT *, ' ' END SUBROUTINE DESCRIBE_EXAMPLE_106 SUBROUTINE ELEM_SQ_EX_106 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_SOURCE IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) REAL(DP) :: SOURCE ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! NOTE: IS_ELEMENT SHOULD BE TRUE HERE ! .............................................................. ! Define any new array or variable types, then give statements ! ! APPLICATION DEPENDENT Galerkin MWR FOR ODE ! Y'' - 2XY'/(X^2+1) + 2Y/(X^2+1) = (X^2+1), Fausett p. 482 ! Y'' + f_1 Y' + f_2 Y = f_3 , Fausett p. 482 ! -f_3 given in SELECT_EXACT_SOURCE or my_source_inc REAL(DP) :: DL, DX_DR ! Length, Jacobian REAL(DP) :: f_1, f_2, f_3 ! Length, Jacobian !b REAL(DP) :: NORM_SQ (LT_FREE, LT_FREE) ! elem norm INTEGER :: IQ ! Loops DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL / 2. ! CONSTANT JACOBIAN E(1, 1) = 1 ! identity matrix !b NORM_SQ = 0.d0 ! S, C already zeroed CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !b DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! GET VARIABLE COEFFICIENTS f_3 = 1.d0 + XYZ (1) **2 ; SOURCE = -f_3 f_2 = 2.d0 / f_3 f_1 = -XYZ (1) * f_2 ! LOCAL AND GLOBAL DERIVATIVES DLH = GET_DLH_AT_QP (IQ) DGH = DLH / DX_DR ! RESULTANT SOURCE VECTOR !b via EXACT_CASE value or my_source_inc !b CALL SELECT_EXACT_SOURCE (XYZ, SOURCE) C = C + SOURCE * H * WT (IQ) * DX_DR ! SQUARE MATRIX S = S + MATMUL (TRANSPOSE(DGH), DGH) * WT (IQ) * DX_DR & - f_1 * OUTER_PRODUCT (H, DGH(1, :)) * WT (IQ) * DX_DR & - f_2 * OUTER_PRODUCT (H, H) * WT (IQ) * DX_DR !b ! NORM MATRIX !b NORM_SQ = NORM_SQ + ( MATMUL (TRANSPOSE(DGH), DGH) & !b + OUTER_PRODUCT (H, H) ) * WT (IQ) * DX_DR CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) !b END DO ! QUADRATURE !b IF ( N_FILE2 > 0) WRITE (N_FILE2) NORM_SQ ! FOR H_1_NORM POST_PROC ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_106 SUBROUTINE MIXED_SQ_EX_106 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE MIXED_BC SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_ROBIN_DATA IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** MIXED_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Mixed or Robin boundary condition, Standard form: ! K_n * U,n + ROBIN_1_SEG * U + ROBIN_2_SEG = 0 ! GET ROBIN_DATA COMPONENTS, These are point values !b XYZ (:) = COORD (1, :) ! A point "element" !b CALL SELECT_EXACT_ROBIN_DATA (XYZ, ROBIN_1_SEG, ROBIN_2_SEG) !b S (1, 1) = ROBIN_1_SEG !b sign ?? xxx !b C (1) = -ROBIN_2_SEG !b sign ?? xxx ! GET ROBIN_DATA COMPONENTS, These are point values IF ( MIXED_REAL > 1 ) THEN !bb ROBIN_1_SEG = GET_REAL_MX (1) ! recover mixed seg data ROBIN_2_SEG = GET_REAL_MX (2) ! recover mixed seg data ELSE !bb XYZ (:) = COORD (1, :) ! A point "element" !bb CALL SELECT_EXACT_ROBIN_DATA (XYZ, ROBIN_1_SEG, ROBIN_2_SEG) !bb END IF !bb S (1, 1) = ROBIN_1_SEG ! square "matrix" C (1) = -ROBIN_2_SEG ! column "vector" IF ( DEBUG_MIX_SQ ) THEN print *, 'MIXED_REAL ', MIXED_REAL print *, 'S (1, 1) ', S (1, 1) print *, 'C (1) ', C (1) END IF ! END APPLICATION DEPENDENT MIXED_SQ_MATRIX STATEMENTS ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE MIXED_SQ_EX_106 SUBROUTINE POST_PROCESS_ELEM_EX_106 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_106 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_ELEM_EX_106' END SUBROUTINE POST_PROCESS_ELEM_EX_106 ! ============= End Files for EXAMPLE number 106 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 107 ============= SUBROUTINE DESCRIBE_EXAMPLE_107 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 107 ***' PRINT *, 'LEAST SQUARES METHOD SOLUTION OF' PRINT *, "Y'' - 2XY'/(X^2+1) + 2Y/(X^2+1) = (X^2+1)" PRINT *, 'USING 3-RD ORDER HERMITE ELEMENTS IN UNIT COORDINATES' END SUBROUTINE DESCRIBE_EXAMPLE_107 SUBROUTINE B_MATRIX_EX_107 (DGH, XYZ, B) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT B MATRIX FOR STRAIN OR GRADIENTS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for LT_N, LT_FREE, & H (LT_N) IF NEEDED IMPLICIT NONE REAL (DP), INTENT(IN) :: DGH (N_SPACE, LT_N) REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: B (N_R_B, LT_FREE) ! ................................................................... ! ** GET_APPLICATION_B_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW ** ! For REAL (DP) :: B (N_R_B, LT_FREE) ! Given REAL (DP), INTENT(IN) :: DGH (N_SPACE, LT_N), XYZ (N_SPACE) ! ................................................................... ! LEAST SQ. SOL. OF: Y'' - 2XY'/(X^2+1) + 2Y/(X^2+1) = (X^2+1) ! Define any new array or variable types, then give statements REAL(DP) :: DGV (LT_FREE) ! v' NOT GLOBAL as in my_el_sq_inc REAL(DP) :: D2GV (LT_FREE) ! v'' REAL(DP) :: PT_UNIT ! unit coord pt REAL(DP) :: DL ! physical length ! DGV = DERIVATIVE OF GENERALIZED (VECTOR) INTERPOLATION ! D2GV = SECOND DERIVATIVE OF GENERALIZED (VECTOR) INTERPOLATION ! used only in the error estimator IF ( DEBUG_B .OR. DEBUG_INCLUDE ) & WRITE (N_BUG, *) 'Entering my_b_matrix_inc' DL = COORD (2, 1) - COORD (1, 1) PT_UNIT = (XYZ (1) - COORD (1, 1)) / DL CALL DERIV_C1_L (PT_UNIT, DL, DGV) ! DV / DX CALL DERIV2_C1_L (PT_UNIT, DL, D2GV) ! D^2 V / DX^2 B (1, :) = DGV (:) ! NOT Global B (2, :) = D2GV (:) ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, DGH (1, 1), XYZ END SUBROUTINE B_MATRIX_EX_107 SUBROUTINE ELEM_SQ_EX_107 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! LEAST SQ. SOL. OF: Y'' - 2XY'/(X^2+1) + 2Y/(X^2+1) = (X^2+1) ! a) WITH Y(0)=2, Y(1)=5/3, Y(X) = X^4/6 - 3X^2/2 + X + 2 (p482) ! b) WITH Y(0)=1 AND MPC Y'(1)+Y(1)=0 (p484) ! Y(X) = (x^4 -3X^2 -X +6)/6 ! c) WITH MPCs: Y'(0)+Y(0)=0, Y'(1)-Y(1)=3 ! SO Y(X) = X^4/6 + 3X^2/2 + X - 1, Fausett p. 485 ! USING 3-RD ORDER HERMITE ELEMENTS IN UNIT COORDINATES ! >>> NOTE NOT SCALAR INTERPOLATION, C_1 ELEMENTS <<< ! ------------------------------------------- REAL(DP) :: D2GV (LT_FREE) ! v'' REAL(DP) :: F (LT_FREE) ! Nonlinear Workspace REAL(DP) :: PT_UNIT, WT_UNIT ! unit coord pt, weight REAL(DP) :: DL, X_PT, X_SQ ! physical length INTEGER :: IP ! loops ! DGV = DERIVATIVE OF GENERALIZED (VECTOR) INTERPOLATION ! D2GV = SECOND DERIVATIVE OF GENERALIZED (VECTOR) INTERPOLATION ! V = GENERALIZED (VECTOR) INTERPOLATION FUNCTIONS IF ( DEBUG_EL_SQ .OR. DEBUG_INCLUDE ) & WRITE (N_BUG, *) 'Entering my_b_matrix_inc' E = GET_REAL_IDENTITY (N_R_B) ! DUMMY CONSTITUTIVE DL = COORD (2, 1) - COORD (1, 1) ! GET THE LENGTH CALL STORE_FLUX_POINT_COUNT ! Save LT_QP ! NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP !--> FIND UNIT COORDINATES AND WEIGHT FOR INTEGRATION PT_UNIT = (1.d0 + PT(1,IP)) / 2.d0 WT_UNIT = WT (IP) / 2.0d0 XYZ (1) = COORD (1, 1) + PT_UNIT * DL X_SQ = XYZ (1) * XYZ (1) !--> EVALUATE HERMITE SHAPE FUNCTIONS AND DERIVATIVES CALL SHAPE_C1_L (PT_UNIT, DL, V) ! V (NOT H) CALL DERIV_C1_L (PT_UNIT, DL, DGV) ! DV / DX CALL DERIV2_C1_L (PT_UNIT, DL, D2GV) ! D^2 V / DX^2 ! WORK VECTOR, F = Y'' - 2XY'/(X^2+1) + 2Y/(X^2-1) F = D2GV - 2.d0 * XYZ (1) * DGV(1,:) / (X_SQ + 1.d0) & + 2.d0 * V / (X_SQ + 1.d0) ! COMPLETE THE SQUARE MATRIX AND SOURCE VECTOR ! S_IJ = S_IJ + WT_UNIT * F_I * F_J * DL S = S + WT_UNIT * OUTER_PRODUCT (F, F) * DL C = C + WT_UNIT * (X_SQ + 1.d0) * F * DL ! STORE DATA FOR SCP OR POST PROCESSING B (1, :) = DGV (1, :) ; B (2, :) = D2GV (:) CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_107 SUBROUTINE POST_PROCESS_ELEM_EX_107 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_107 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_ELEM_EX_107' END SUBROUTINE POST_PROCESS_ELEM_EX_107 ! ============= End Files for EXAMPLE number 107 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 108 ============= SUBROUTINE DESCRIBE_EXAMPLE_108 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 108 ***' PRINT *, 'A conducting, convection truss member with heat generation' PRINT *, 'Equation: K*A U,xx - H*P (U - U_ext) - Q_e= 0,' PRINT *, 'U = temperature, K = conductivity,' PRINT *, 'A = area, H = convection coeff,' PRINT *, 'P = perimeter, Q_e = heat source per unit length.' END SUBROUTINE DESCRIBE_EXAMPLE_108 SUBROUTINE ELEM_SQ_EX_108 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! 108.my_el_sq_inc ! A conducting, convection truss member with heat generation ! Equation: K*A U,xx - H*P (U - U_e) + Q_e = 0, ! U = temperature, K = conductivity, A = area, H = convection coeff, ! P = perimeter, Q_e = heat source per unit length ! 1 *---(K_e, A_e, h_e, P_e, U_e, Q_e)---* 2, Element in xyz REAL(DP) :: L_BAR ! Length REAL(DP) :: K_e, A_e, h_e, P_e, U_e, Q_e ! properties IF ( debug_el_sq .or. debug_include ) & WRITE (N_BUG, *) 'Entering my_el_sq_inc' L_BAR = SQRT( SUM( (COORD (2, 1:N_SPACE) & - COORD (1, 1:N_SPACE)) **2) ) K_e = GET_REAL_LP (1) ! thermal conductivity A_e = GET_REAL_LP (2) ! area of bar h_e = GET_REAL_LP (3) ! convection coefficent on perimeter P_e = GET_REAL_LP (4) ! perimeter of area A_e Q_e = GET_REAL_LP (5) ! source per unit length, BTU/ hr ft U_e = GET_REAL_LP (6) ! convecting temperature, F S (1, 1) = K_e * A_e / L_BAR + h_e * P_e * L_BAR / 3.d0 S (2, 1) = -K_e * A_e / L_BAR + h_e * P_e * L_BAR / 6.d0 S (1, 2) = -K_e * A_e / L_BAR + h_e * P_e * L_BAR / 6.d0 S (2, 2) = K_e * A_e / L_BAR + h_e * P_e * L_BAR / 3.d0 C (1) = (h_e * P_e * U_e + Q_e) * L_BAR / 2.d0 C (2) = (h_e * P_e * U_e + Q_e) * L_BAR / 2.d0 ! end file: my_el_sq_inc ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_108 ! ============= End Files for EXAMPLE number 108 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 109 ============= SUBROUTINE DESCRIBE_EXAMPLE_109 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 109 ***' PRINT *, 'Cylindrical Heat Transfer' PRINT *, '1/R * d[R K_RR dT/dR]/dR + Q = 0,' PRINT *, 'K_RR = GET_REAL_LP (1) ; Q = GET_REAL_LP (2' END SUBROUTINE DESCRIBE_EXAMPLE_109 SUBROUTINE E_MATRIX_EX_109 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) ! ................................................................... ! ** GET_APPLICATION_E_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW ** ! For required REAL (DP) :: E (N_R_B, N_R_B) ! Given INTEGER, INTENT (IN) :: N_R_B ! ................................................................... ! used only in the error estimator IF ( DEBUG_INCLUDE .OR. DEBUG_E ) & WRITE (N_BUG, *) 'Entering my_e_matrix_inc' E (1, 1) = GET_REAL_LP (1) ! K_RR ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ END SUBROUTINE E_MATRIX_EX_109 SUBROUTINE ELEM_SQ_EX_109 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! 109.my_el_sq_inc ! CYLINDRICAL HEAT CONDUCTION, (see Section 6.2) ! Global constant TWO_PI = 6.2831853072d0 REAL(DP) :: CONST, DET REAL(DP) :: K_RR, SOURCE INTEGER :: IP ! 1/R * d[R K_RR dT/dR]/dR + Q = 0, Example 109 ! PROP_1 = CONDUCTIVITY K_RR ! PROP_2 = SOURCE PER UNIT VOLUME, Q, or use my_exact_source_inc !--> DEFINE ELEMENT PROPERTIES K_RR = GET_REAL_LP (1) ; SOURCE = GET_REAL_LP (2) E (1, 1) = K_RR ! CONSTITUTIVE ! STORE NUMBER OF POINTS FOR FLUX CALCULATIONS CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !--> NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND RADIUS (R), ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT ! FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) CONST = TWO_PI * DET * WT(IP) * XYZ (1) ! TWO_PI*|J|*w*R ! EVALUATE GLOBAL DERIVATIVES, DGH == B DGH = MATMUL (AJ_INV, DLH) B = COPY_DGH_INTO_B_MATRIX (DGH) ! B = DGH C = C + CONST * SOURCE * H ! VOLUMETRIC SOURCE OPTION ! CONDUCTION SQUARE MATRIX S = S + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_109 ! ============= End Files for EXAMPLE number 109 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 110 ============= SUBROUTINE DESCRIBE_EXAMPLE_110 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 110 ***' PRINT *, 'Cylindrical Stress Analysis, (see Section 6.3)' PRINT *, "Elem prop: Young's modulus, Poisson's ratio, Mass density" PRINT *, 'Misc prop: Spin about z-axis, radians per second' END SUBROUTINE DESCRIBE_EXAMPLE_110 SUBROUTINE B_MATRIX_EX_110 (DGH, XYZ, B) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT B MATRIX FOR STRAIN OR GRADIENTS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for LT_N, LT_FREE, & H (LT_N) IF NEEDED Use Interface_Header ! for COPY_DGH_INTO_B_MATRIX IMPLICIT NONE REAL (DP), INTENT(IN) :: DGH (N_SPACE, LT_N) REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: B (N_R_B, LT_FREE) ! ................................................................... ! ** GET_APPLICATION_B_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW ** ! For REAL (DP) :: B (N_R_B, LT_FREE) ! Given REAL (DP), INTENT(IN) :: DGH (N_SPACE, LT_N), XYZ (N_SPACE) ! ................................................................... B (1, :) = DGH (1, :) ! DU/DR radial strain B (2, :) = H (:) / XYZ (1) ! U/R hoop strain ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, DGH (1, 1), XYZ END SUBROUTINE B_MATRIX_EX_110 SUBROUTINE E_MATRIX_EX_110 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) ! ................................................................... ! ** GET_APPLICATION_E_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW ** ! For required REAL (DP) :: E (N_R_B, N_R_B) ! Given INTEGER, INTENT (IN) :: N_R_B ! ................................................................... REAL(DP) :: E_mod, P_ratio, Rho, Spin ! used only in the error estimator IF ( DEBUG_INCLUDE .OR. DEBUG_E ) & WRITE (N_BUG, *) 'Entering my_e_matrix_inc' E_mod = GET_REAL_LP (1) ; P_ratio = GET_REAL_LP (2) Rho = GET_REAL_LP (3) ; Spin = GET_REAL_MISC (1) ! CONSTITUTIVE LAW E(1,1) = E_mod * (1 - P_ratio)/((1 + P_ratio)*(1 - 2*P_ratio)) E(2,1) = E_mod * P_ratio/((1 + P_ratio)*(1 - 2*P_ratio)) E(1,2) = E(2,1) ; E(2,2) = E(1,1) ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ END SUBROUTINE E_MATRIX_EX_110 SUBROUTINE ELEM_SQ_EX_110 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE, TWO_PI Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! 110.my_el_sq_inc ! Cylindrical Stress Analysis, (see Section 6.3) REAL(DP) :: CONST, DET REAL(DP) :: E_mod, P_ratio, Rho, Spin INTEGER :: IP ! Elem real prop: Young's modulus, Poisson's ratio, Mass density ! Misc real prop: Spin about z-axis, radians per second E_mod = GET_REAL_LP (1) ; P_ratio = GET_REAL_LP (2) Rho = GET_REAL_LP (3) ; Spin = GET_REAL_MISC (1) ! CONSTITUTIVE LAW E(1,1) = E_mod * (1 - P_ratio)/((1 + P_ratio)*(1 - 2*P_ratio)) E(2,1) = E_mod * P_ratio/((1 + P_ratio)*(1 - 2*P_ratio)) E(1,2) = E(2,1) ; E(2,2) = E(1,1) ! STORE NUMBER OF POINTS FOR FLUX CALCULATIONS CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !--> NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND RADIUS (R), ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT ! FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) CONST = TWO_PI * DET * WT(IP) * XYZ (1) ! TWO_PI*|J|*w*R ! EVALUATE GLOBAL DERIVATIVES & STRAIN-DISPLACEMENT DGH = MATMUL (AJ_INV, DLH) B (1, :) = DGH (1, :) ! DU/DR radial strain B (2, :) = H (:) / XYZ (1) ! U/R hoop strain ! STIFFNESS MATRIX S = S + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) BODY = - Rho * XYZ (1) * Spin **2 ! -Rho R Omega^2 C = C + CONST * BODY (1) * H ! CENTRIFUGAL FORCE RESULT !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_110 ! ============= End Files for EXAMPLE number 110 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 111 ============= SUBROUTINE DESCRIBE_EXAMPLE_111 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 111 ***' PRINT *, 'Direct Current Network' PRINT *, 'Elem prop: resistance' PRINT *, 'Results: Voltage at nodes' PRINT *, 'ELEMENT REACTIONS ARE THE IN & OUT CURRENT FLOWS' END SUBROUTINE DESCRIBE_EXAMPLE_111 SUBROUTINE ELEM_SQ_EX_111 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE, TWO_PI Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! 111.my_el_sq_inc ! NOTE: ELEMENT REACTIONS ARE THE IN & OUT CURRENT FLOWS REAL(DP) :: resistance, conductance ! R, 1/R ! Get resistance resistance = GET_REAL_LP (1) ! real element property IF ( resistance > 0.d0 ) THEN conductance = 1.d0 / resistance ELSE PRINT *, 'WARNING: Invalid resistance, element ', IE N_WARN = N_WARN + 1 ; conductance = 1.d0 END IF ! valid data ! Conductance matrix S (1,1) = conductance ; S (2,1) = -conductance S (1,2) = -conductance ; S (2,2) = conductance ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_111 ! ============= End Files for EXAMPLE number 111 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 112 ============= SUBROUTINE DESCRIBE_EXAMPLE_112 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 112 ***' PRINT *, 'SUPG Advection-Diffusion in 1-D for L2, L3, or L4' PRINT *, 'u * dp/dx - d(k * dp/dx)/dx = Q; u, k, Q constan' PRINT *, 'u = GET_REAL_LP (1) ! velocity' PRINT *, 'k = GET_REAL_LP (2) ! conductivity' PRINT *, 'Q = GET_REAL_LP (3) ! source per unit length' PRINT *, 'Misc integer: Galerkin option = 0, 1=SUPG' PRINT *, 'Misc real: fake Pe overwritten for exact solution' END SUBROUTINE DESCRIBE_EXAMPLE_112 SUBROUTINE ELEM_SQ_EX_112 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE, X) !b L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu REAL(DP), INTENT(IN) :: X (MAX_NP, N_SPACE) ! Global coordinates ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! Define any new array or variable types, then give statements ! ! Galerkin or SUPG 1-d Advection-Diffusion Problem ! u * dp/dx - d(k * dp/dx)/dx = Q, assume u, k, Q constant ! ! u = GET_REAL_LP (1) ! velocity ! k = GET_REAL_LP (2) ! conductivity ! Q = GET_REAL_LP (3) ! source per unit length ! OPTION = GET_INTEGER_MISC (1) ! 0=Galerkin (default), 1=SUPG ! Pe_sys = GET_REAL_MISC (1) ! System Peclet, for exact solution ! LT_N = number of nodes for this element type ! MISC_FL = number of real miscellaneous properties ! MISC_FX = number of integer miscellaneous properties ! N_LP_FLO = number of real element properties ! W = Petrov weight, DGW its global derivative REAL(DP) :: W (LT_N), DGW (1, LT_N) ! SUPG & deriv REAL(DP) :: D2GH (1, LT_N) ! SUPG, zero ? REAL(DP) :: DL, DX_DR, DL_A ! Length, Jacobian REAL(DP) :: u, k, Q ! speed, diffusion, source REAL(DP) :: Pe, A, COTH ! Peclet data, L2 INTEGER :: IQ ! Loops REAL(DP), SAVE :: Pe_max ! debugging INTEGER, SAVE :: OPTION = 0 ! Method of solution DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH ELEM DX_DR = DL / 2. ! CONSTANT JACOBIAN DL_A = DL / (LT_N - 1) ! SUPG length ! DATA READS AND SAVES u = GET_REAL_LP (1) ! velocity k = GET_REAL_LP (2) ; E = k ! conductivity Q = 0.d0 ; IF ( N_LP_FLO > 2 ) Q = GET_REAL_LP (3) ! source E = k ! constitutive IF ( IE == 1 ) THEN ! FIRST ELEMENT, ONE TIME ACTIONS Pe_max = 0.d0 ! initialize IF ( MISC_FX > 0 ) OPTION = GET_INTEGER_MISC (1) ! 0=Galerkin, 1=SUPG IF ( OPTION == 0 ) THEN ! echo choice PRINT *,'NOTE: Galerkin method' ! default ELSE ; PRINT *,'NOTE: SUPG method' ; END IF ! supg IF ( (USE_EXACT .OR. USE_EXACT_FLUX) .AND. MISC_FL == 0 ) THEN PRINT *, 'WARNING: ELEM_SQ_MATRIX, to use Pe_sys in exact ' PRINT *, 'solution set keyword "reals 1" in control' N_WARN = N_WARN + 1 ; END IF ! exact data given END IF ! FIRST ELEMENT ! SUPG TERMS (ASSUMING L2 ELEMENT), ? Bias for L3, L4 ? Pe = u * DL / k ! Grid Peclet IF ( Pe > Pe_max ) Pe_max = Pe ! for debug COTH = COSH (Pe/2) / SINH (Pe/2) ! Optimal SUPG A = ABS (COTH) - 1.d0 / ABS (Pe/2) ! Optimal SUPG L2 A = SIGN (A, u) ! abs(A) * sign of u ! ------- ELEMENT MATRICES FORMATION ---------- CALL STORE_FLUX_POINT_COUNT ! Save LT_QP FOR SCP DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES, S, C already zeroed ! GET TRIAL INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) ! SOLUTION INTERPOLATION XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL FIRST DERIVATIVES DLH = GET_DLH_AT_QP (IQ) ! LOCAL DERIVATIVE DGH = DLH / DX_DR ! PHYSICAL DERIVATIVE ! *** SELECT STANDARD GALERKIN OR SUPG *** IF ( OPTION == 0 ) THEN ! Galerkin W = H ; DGW (1, :) = DGH (1, :) ELSE ! SUPG Method ! LOCAL AND GLOBAL SECOND DERIVATIVES (FOR N_SPACE == 1) SELECT CASE (LT_N) ! ELEMENT LIBRARY CASE (2) ; D2LH = 0.d0 ! L2 CASE (3) ; CALL DERIV2_3_L (PT (1, IQ), D2LH (1, :)) ! L3 CASE (4) ; CALL DERIV2_4_L (PT (1, IQ), D2LH (1, :)) ! L4 CASE DEFAULT ; STOP 'SUPG, NO SECOND DERIVATIVE IN LIBRARY' END SELECT D2GH = D2LH / DX_DR**2 ! PHYSICAL SECOND DERIVATIVE ! SUPG WEIGHTINGS, NOTE SECOND DERIVATIVE IN DGW W = H + A * DGH (1, :) * DL_A * 0.5d0 DGW (1, :) = DGH (1, :) + A * D2GH (1, :) * DL_A * 0.5d0 ! PRE-INSERT SECOND DERIVATIVE RESIDUAL, IF ANY IF ( LT_N > 2 ) S = S + k * A * DL_A * WT (IQ) * DX_DR & * OUTER_PRODUCT (DGH (1, :), D2GH (1, :)) END IF ! Method option ! MATRICES: SOURCE, CONDUCTION & ADVECTION C = C + Q * W * WT (IQ) * DX_DR ! SOURCE S = S + ( k * MATMUL (TRANSPOSE(DGH), DGH) & + u * OUTER_PRODUCT (W, DGH(1,:) )) * WT (IQ) * DX_DR !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) END DO ! QUADRATURE IF ( IE == N_ELEMS ) PRINT *, 'Maximum element Pe = ', PE_max ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** END SUBROUTINE ELEM_SQ_EX_112 SUBROUTINE POST_PROCESS_ELEM_EX_112 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_112 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_ELEM_EX_112' END SUBROUTINE POST_PROCESS_ELEM_EX_112 ! ============= End Files for EXAMPLE number 112 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 113 ============= SUBROUTINE DESCRIBE_EXAMPLE_113 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 113 ***' PRINT *,'An axial elastic bar using closed form linear elements' PRINT *,'Element properties: 1-area, 2-elastic modulus, 3-temperature' PRINT *,'rise, 4-coeff. of thermal expansion, 5- weight per unit volume' PRINT *,'Element post-processing lists the mechanical strain, thermal' PRINT *,'strain, and mechanical stress, at the element center' END SUBROUTINE DESCRIBE_EXAMPLE_113 SUBROUTINE ELEM_SQ_EX_113 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! AN AXIAL BAR BY DIRECT ENERGY APPROACH ! ELEMENT REAL PROPERTIES: (1) = AREA, (2) = ELASTIC MODULUS ! (3) = TEMP RISE, (4) = COEFF EXPANSION, (5) = WEIGHT DENSITY REAL(DP) :: BAR_L ! length REAL(DP) :: DELTA_T, ALPHA ! temp rise, expansion REAL(DP) :: AREA, GAMMA ! area, wt. density REAL(DP) :: M_E, THERMAL ! modulus, thermal strain ! Get properties for this element AREA = GET_REAL_LP (1); M_E = GET_REAL_LP (2) DELTA_T = GET_REAL_LP (3); ALPHA = GET_REAL_LP (4) GAMMA = GET_REAL_LP (5) ! Find bar length and direction cosines BAR_L = COORD (2, 1) - COORD (1, 1) ! length ! Form global strain-displacement matrix B (1, :) = (/ -1, 1 /) / BAR_L ! Form global stiffness, S = B' EAL B S = M_E * AREA * BAR_L * MATMUL ( TRANSPOSE (B), B ) ! Initial (thermal) strain loading THERMAL = ALPHA * DELTA_T ! strain C = B (1, :) * M_E * THERMAL * AREA * BAR_L ! force ! Weight load, in positive X-direction (wt density * volume) C = C + (/ 0.5d0, 0.5d0 /) * GAMMA * AREA * BAR_L ! total weight ! Save for stress post-processing (set post_1 in keywords) IF ( N_FILE1 > 0 ) WRITE (N_FILE1) M_E, B, THERMAL ! End of application dependent code ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_113 SUBROUTINE POST_PROCESS_ELEM_EX_113 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_113 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! AN AXIAL BAR BY DIRECT ENERGY APPROACH ! ELEMENT REAL PROPERTIES: (1) = AREA, (2) = ELASTIC MODULUS ! (3) = TEMP RISE, (4) = COEFF EXPANSION, (5) = WEIGHT DENSITY ! STRESS = M_E * (MECHANICAL STRAIN - INITIAL STRAIN) REAL(DP) :: THERMAL, M_E ! initial strain, modulus LOGICAL, SAVE :: FIRST = .TRUE. ! printing IF ( FIRST ) THEN ! first call FIRST = .FALSE. ; WRITE (6, 5) ! print headings 5 FORMAT (' E L E M E N T S T R E S S E S', /, & & ' ELEMENT STRESS MECH. STRAIN THERMAL STRAIN') END IF ! first call !--> Read stress strain data from N_FILE1 (set by post_1) READ (N_FILE1) M_E, B, STRAIN_0 (1) ! THERMAL = STRAIN_0 !--> Calculate mechanical strain, STRAIN = B * D STRAIN (1) = DOT_PRODUCT ( B(1, :), D ) !--> Generalized Hooke's Law STRESS (1) = M_E * (STRAIN (1) - STRAIN_0 (1)) WRITE (6, 1) IE, STRESS (1), STRAIN (1), STRAIN_0 (1) 1 FORMAT (I5, 3ES15.5) ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_113 !============= End Files for EXAMPLE number 113 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 114 ============= SUBROUTINE DESCRIBE_EXAMPLE_114 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 114 ***' PRINT *,'Heat & Mass Transfer in 1-D: (unsymmetric system) L2 ONLY' PRINT *,'Equation: K*A U,xx - H*P (U - U_e) - m_dot*c_p*U,x + Q_e = 0,' PRINT *,'1 *---(Properties)---* 2, Properties are:' PRINT *,'1: K_e = thermal conductivity' PRINT *,'2: A_e = area of bar' PRINT *,'3: h_e = convection coefficent on perimeter' PRINT *,'4: P_e = perimeter of area A_e' PRINT *,'5: Q_e = source per unit length, BTU/ hr ft' PRINT *,'6: U_e = convecting temperature, F' PRINT *,'7: m_dot = mass flow rate' PRINT *,'8: c_p = specific heat, constant pressure' END SUBROUTINE DESCRIBE_EXAMPLE_114 SUBROUTINE ELEM_SQ_EX_114 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! For required REAL (DP) :: S (LT_FREE, LT_FREE) ! and optional REAL (DP) :: C (LT_FREE) ! .............................................................. ! Define any new array or variable types, then give statements ! Heat and Mass Transfer in 1-D: (unsymmetric system) L2 ONLY ! Equation: K*A U,xx - H*P (U - U_e) - m_dot*c_p*U,x + Q_e = 0, ! U = temperature, K = conductivity, A = area, H = convection coeff, ! P = perimeter, m_dot = mass flow rate, c_p = specific heat, ! Q_e = heat source per unit length ! 1 *---(K_e, A_e, h_e, P_e, U_e, m_dot, c_p, Q_e)---* 2, Element in x REAL(DP) :: L_BAR ! Length REAL(DP) :: K_e, A_e, h_e, P_e, U_e, Q_e, m_dot, c_p ! properties L_BAR = SQRT( SUM( (COORD (2, 1:N_SPACE) & - COORD (1, 1:N_SPACE)) **2) ) IF ( EL_REAL < 8 ) PRINT *, 'STOP: NEED el_real 8 FOR MASS TRANSFER' K_e = GET_REAL_LP (1) ! thermal conductivity A_e = GET_REAL_LP (2) ! area of bar h_e = GET_REAL_LP (3) ! convection coefficent on perimeter P_e = GET_REAL_LP (4) ! perimeter of area A_e Q_e = GET_REAL_LP (5) ! source per unit length, BTU/ hr ft U_e = GET_REAL_LP (6) ! convecting temperature, F m_dot = GET_REAL_LP (7) ! mass flow rate c_p = GET_REAL_LP (8) ! specific heat, constant pressure ! conduction and convection effects S (1, 1) = K_e * A_e / L_BAR + h_e * P_e * L_BAR / 3.d0 S (2, 1) = -K_e * A_e / L_BAR + h_e * P_e * L_BAR / 6.d0 S (1, 2) = -K_e * A_e / L_BAR + h_e * P_e * L_BAR / 6.d0 S (2, 2) = K_e * A_e / L_BAR + h_e * P_e * L_BAR / 3.d0 ! mass transfer effects S (1, 1) = S (1, 1) - m_dot * c_p / 2 S (2, 1) = S (2, 1) - m_dot * c_p / 2 S (1, 2) = S (1, 2) + m_dot * c_p / 2 S (2, 2) = S (2, 2) + m_dot * c_p / 2 ! convection and source effects C (1) = (h_e * P_e * U_e + Q_e) * L_BAR / 2.d0 C (2) = (h_e * P_e * U_e + Q_e) * L_BAR / 2.d0 ! end file: my_el_sq_inc ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_114 !============= End Files for EXAMPLE number 114 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 115 ============= !============= End Files for EXAMPLE number 115 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 116 ============= !============= End Files for EXAMPLE number 116 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 117 ============= !============= End Files for EXAMPLE number 117 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 118 ============= !============= End Files for EXAMPLE number 118 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 119 ============= !============= End Files for EXAMPLE number 119 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 120 ============= !============= End Files for EXAMPLE number 120 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 121 ============= SUBROUTINE DESCRIBE_EXAMPLE_121 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE = 121 PRINT *, "*** DESCRIPTIONS OF EXAMPLE ", EXAMPLE, " ***" PRINT *, "Galerkin FOR TRANSIENT DE VIA ITERATION " PRINT *, "K U,xx - R U,t = 0, with U(x,0), U(0,t), U(L,t)" PRINT *, "----------------------------------------" PRINT *, "Uses iteration loops to manually treat time integration" PRINT *, "NOTE: This is very inefficient since the matrices" PRINT *, "generation, assembly, boundary conditions, and " PRINT *, "factorization are repeated ever time step (iteration)" PRINT *, "Need key relaxation 1.0 so D_OLD replaced by D_NEW" PRINT *, "Keyword time_step 1.d-3, etc sets time step size" PRINT *, "Keyword time_method sets method: " PRINT *, " 1-Euler, 2-Crank-Nicolson, 3-Galerkin, 4-Least Sq" END SUBROUTINE DESCRIBE_EXAMPLE_121 SUBROUTINE ELEM_SQ_EX_121 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! begin file 121.my_el_sq_inc ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! For required REAL (DP) :: S (LT_FREE, LT_FREE) ! and optional REAL (DP) :: C (LT_FREE) ! using previous solution D (LT_FREE) with ! D = D_OLD + RELAXATION (D_NEW - D_OLD) via key relaxation 1.0 ! Globals START_TIME, TIME_STEP, TIME are available ! DIAG_M (LT_FREE) is global ! .............................................................. ! APPLICATION DEPENDENT Galerkin FOR TRANSIENT DE ! via element level assembly of semi-discrete form(s) ! K_e U,xx + Q - Rho_e U,t = 0, with U(x,0) given by keyword ! start_value, U(0,t) and U(L,t) given by EBC constant in time ! Keywords time_step, time_method, scalar_source, ! diagonal_mass are also available ! Spatial items REAL(DP) :: DL, DX_DR, Q = 0.d0 ! Length, Jacobian, source INTEGER :: IQ, J ! Loops ! Work items for time integration INTEGER, SAVE :: METHOD = 1 ! defaults REAL(DP), SAVE :: Del_t = 1.d0 ! defaults REAL(DP), SAVE :: K_e = 1.d0, Rho_e = 1.d0 ! defaults REAL(DP) :: K (LT_FREE, LT_FREE), M (LT_FREE, LT_FREE) REAL(DP) :: F (LT_FREE), WORK (LT_FREE, LT_FREE) IF ( debug_el_sq .or. debug_include ) & WRITE (N_BUG, *) 'Entering my_el_sq_inc' IF ( THIS_EL == 1 ) THEN METHOD = TIME_METHOD ! keyword option time_method IF ( INTEGERS > 0 ) METHOD = GET_INTEGER_MISC (1) ! alt IF ( TIME_STEP /= 1.d0 ) Del_t = TIME_STEP TIME = START_TIME + THIS_ITER * TIME_STEP PRINT *, 'TIME = ', TIME END IF K = 0 ; M = 0 ; F = 0 ! Initialize spatial arrays IF ( N_LP_FLO > 1 ) THEN ! use non-default properties K_e = GET_REAL_LP (1) ! thermal conductivity Rho_e = GET_REAL_LP (2) ! rho, c_p END IF E = K_e ! Diffusion DL = COORD (LT_N, 1) - COORD (1, 1) ! Length DX_DR = DL / 2. ! Jacobian IF ( SCALAR_SOURCE /= 0.d0 ) Q = SCALAR_SOURCE ! source CALL STORE_FLUX_POINT_COUNT ! Save LT_QP for post-processing DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL DERIVATIVES, B = DGH DLH = GET_DLH_AT_QP (IQ) ! dH / dr DGH = DLH / DX_DR ! dH / dx ! SQUARE MATRICES (STIFFNESS & MASS) & SOURCE VECTOR K = K + MATMUL (TRANSPOSE(DGH), DGH)* WT (IQ) * DX_DR * K_e M = M + OUTER_PRODUCT (H, H) * WT (IQ) * DX_DR * Rho_e F = F + H * Q * WT (IQ) * DX_DR CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) ! for post-processing END DO ! QUADRATURE ! Assemble for semi-discrete one-step time rule ! NOTE: This is very inefficient since the assembly, boundary ! conditions, and factorization are repeated ever time step IF ( DIAGONAL_MASS ) THEN ! use the scaled diagonal mass form CALL DIAGONALIZE_SQ_MATRIX (LT_FREE, M, DIAG_M) ; M = 0.d0 DO J = 1, LT_FREE M (J, J) = DIAG_M (J) END DO END IF SELECT CASE ( METHOD ) ! for one-step time integration rule CASE ( 2 ) ! Crank-Nicolson WORK = M / Del_t - K / 2 C = F + MATMUL (WORK, D) S = M / Del_t + K / 2 CASE ( 3 ) ! Galerkin continuous in time WORK = M / Del_t - K / 3 C = F + MATMUL (WORK, D) S = 2 * K / 3.d0 + M / Del_t CASE ( 4 ) ! Least Squares in time, F constant in time WORK = MATMUL (TRANSPOSE(M), M) / Del_t & + MATMUL (TRANSPOSE(K), M) / 2 & - MATMUL (TRANSPOSE(M), K) / 2 & - MATMUL (TRANSPOSE(K), K) * Del_t / 6 C = -MATMUL (TRANSPOSE(K), F) * Del_t / 2 & - MATMUL (TRANSPOSE(M), F) & + MATMUL (WORK, D) S = MATMUL (TRANSPOSE(K), K) * Del_t / 3 & + MATMUL (TRANSPOSE(K), M) / 2 & + MATMUL (TRANSPOSE(M), K) / 2 & + MATMUL (TRANSPOSE(M), M) / Del_t CASE DEFAULT ! Method 1, Euler forward difference WORK = M / Del_t C = F + MATMUL (WORK, D) S = K + M / Del_t END SELECT IF ( debug_el_sq .AND. THIS_EL == 1 ) THEN PRINT *, 'K, M, F, WORK, D, S, C for method = ', METHOD CALL RPRINT (K, LT_FREE, LT_FREE, 1) CALL RPRINT (M, LT_FREE, LT_FREE, 1) CALL RPRINT (F, 1, LT_FREE, 1) CALL RPRINT (D, 1, LT_FREE, 1) CALL RPRINT (WORK, LT_FREE, LT_FREE, 1) CALL RPRINT (S, LT_FREE, LT_FREE, 1) CALL RPRINT (C, 1, LT_FREE, 1) END IF ! end file: 121.my_el_sq_inc ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_121 !FUNCTION START_DOF_VALUE_EX_121 (IG, XYZ) !! * * * * * * * * * * * * * * * * * * * * * * * * * * !! DEFINE STARTING VALUE OF PARAMETER IG IN TERMS OF !! COORDINATES OF THE NODE (FOR ITERATIVE SOLUTIONS) !! * * * * * * * * * * * * * * * * * * * * * * * * * * !! A PROBLEM DEPENDENT ROUTINE !Use System_Constants ! For EXAMPLE !IMPLICIT NONE ! INTEGER, INTENT(IN) :: IG ! local dof number ! REAL(DP), INTENT(IN) :: XYZ (N_SPACE) ! position ! REAL(DP) :: START_DOF_VALUE_EX_121 ! result !! IG = LOCAL PARAMETER NUMBER AT NODE !! ................................................................... !! ** START_DOF_VALUE PROBLEM DEPENDENT STATEMENTS FOLLOW ** !! For REAL (DP) :: START_DOF_VALUE ! result !! Given INTEGER, INTENT(IN) :: IG ! local dof number !! REAL(DP), INTENT(IN) :: XYZ (N_SPACE) ! position !! Given modules: Select_source, System_Constants1 !! ................................................................... ! INTEGER, SAVE :: NOTE = 0 ! IF ( NOTE == 0 ) THEN ; NOTE = 1; ! IF ( DEBUG_INCLUDE ) PRINT *, 'NOTE: USED START_DOF_VALUE_EX_121' ! PRINT *,'NOTE: DEFAULT START VALUE IS ', INITIAL_VALUE ! END IF !!--> ASSIGN UNIT STARTING VALUE ONLY ! START_DOF_VALUE_EX_121 = INITIAL_VALUE !! suppress compiler warnings (touch is never true) ! IF ( TOUCH ) PRINT *,'START_DOF_VALUE:', IG, XYZ !END FUNCTION START_DOF_VALUE_EX_121 !============= End Files for EXAMPLE number 121 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 122 ============= SUBROUTINE DESCRIBE_EXAMPLE_122 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE = 122 PRINT *, "*** DESCRIPTIONS OF EXAMPLE ", EXAMPLE, " ***" PRINT *, "APPLICATION DEPENDENT Galerkin FOR TRANSIENT PDE" PRINT *, "via element level assembly of semi-discrete form(s)" PRINT *, "K_e U,xx + Q - Rho_e U,t = 0, with U(x,0) given by" PRINT *, "keyword start_value, U(0,t) and U(L,t) given by EBC" PRINT *, "Keywords time_step, time_steps, time_method, " PRINT *, "scalar_source, and diagonal_mass are also available." PRINT *, "Keyword time_method sets method: " PRINT *, " 1-Euler, 2-Crank-Nicolson, 3-Galerkin, 4-Least Sq" END SUBROUTINE DESCRIBE_EXAMPLE_122 SUBROUTINE ELEM_SQ_EX_122 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! begin file 122.my_el_sq_inc ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! For required REAL (DP) :: S (LT_FREE, LT_FREE) ! and optional REAL (DP) :: EL_M (LT_FREE, LT_FREE) ! or optional REAL (DP) :: DIAG_M C (LT_FREE) ! and optional REAL (DP) :: C (LT_FREE) ! using previous solution D (LT_FREE) with ! Globals START_TIME, TIME_STEP, TIME, TIME_METHOD are available ! .............................................................. ! APPLICATION DEPENDENT Galerkin FOR TRANSIENT DE ! via element level assembly of semi-discrete form(s) ! K_e U,xx + Q - Rho_e U,t = 0, with U(x,0) given by keyword ! start_value, U(0,t) and U(L,t) given by EBC constant in time ! Keywords time_step, time_method, scalar_source, ! diagonal_mass are also available REAL(DP) :: DL, DX_DR, Q = 0.d0 ! Length, Jacobian, Source INTEGER :: IQ, J ! Loops ! Work items for time integration REAL(DP), SAVE :: K_e = 1.d0, Rho_e = 1.d0 ! defaults IF ( debug_el_sq .or. debug_include ) & WRITE (N_BUG, *) 'Entering 122.my_el_sq_inc ', THIS_EL IF ( THIS_EL == 1 ) PRINT *, 'TIME = ', TIME IF ( SCALAR_SOURCE /= 0.d0 ) Q = SCALAR_SOURCE ! source IF ( N_LP_FLO > 1 ) THEN ! use non-default properties K_e = GET_REAL_LP (1) ! thermal conductivity Rho_e = GET_REAL_LP (2) ! rho, c_p END IF E = K_e ! DIFFUSION DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL / 2. ! JACOBIAN S = 0.d0 ; EL_M = 0.d0 ; C = 0.d0 !b CALL STORE_FLUX_POINT_COUNT ! Save LT_QP for post-processing DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL DERIVATIVES, B = DGH DLH = GET_DLH_AT_QP (IQ) ! dH / dr DGH = DLH / DX_DR ! dH / dx ! SQUARE MATRICES (STIFFNESS & MASS) S = S + MATMUL (TRANSPOSE(DGH), DGH)* WT (IQ) * DX_DR * K_e EL_M = EL_M + OUTER_PRODUCT (H, H) * WT (IQ) * DX_DR * Rho_e C = C + H * WT (IQ) * DX_DR * Q CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) ! for post-processing END DO ! QUADRATURE IF ( debug_el_sq .AND. THIS_EL <= 4 ) THEN PRINT *, 'EL_S, EL_M, EL_C lists for method = ', TIME_METHOD CALL RPRINT (S, LT_FREE, LT_FREE, 1) CALL RPRINT (EL_M, LT_FREE, LT_FREE, 1) CALL RPRINT (C, LT_FREE, 1 , 1) END IF ! end file: 122.my_el_sq_inc ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_122 !FUNCTION START_DOF_VALUE_EX_122 (IG, XYZ) !! * * * * * * * * * * * * * * * * * * * * * * * * * * !! DEFINE STARTING VALUE OF PARAMETER IG IN TERMS OF !! COORDINATES OF THE NODE (FOR ITERATIVE SOLUTIONS) !! * * * * * * * * * * * * * * * * * * * * * * * * * * !! A PROBLEM DEPENDENT ROUTINE !Use System_Constants ! For EXAMPLE !IMPLICIT NONE ! INTEGER, INTENT(IN) :: IG ! local dof number ! REAL(DP), INTENT(IN) :: XYZ (N_SPACE) ! position ! REAL(DP) :: START_DOF_VALUE_EX_122 ! result !! IG = LOCAL PARAMETER NUMBER AT NODE !! ................................................................... !! ** START_DOF_VALUE PROBLEM DEPENDENT STATEMENTS FOLLOW ** !! For REAL (DP) :: START_DOF_VALUE ! result !! Given INTEGER, INTENT(IN) :: IG ! local dof number !! REAL(DP), INTENT(IN) :: XYZ (N_SPACE) ! position !! Given modules: Select_source, System_Constants1 !! ................................................................... ! INTEGER, SAVE :: NOTE = 0 ! IF ( NOTE == 0 ) THEN ; NOTE = 1; ! IF ( DEBUG_INCLUDE ) PRINT *, 'NOTE: USED START_DOF_VALUE_EX_122' ! PRINT *,'NOTE: DEFAULT START VALUE IS ', INITIAL_VALUE ! END IF !!--> ASSIGN UNIT STARTING VALUE ONLY ! START_DOF_VALUE_EX_122 = INITIAL_VALUE !! suppress compiler warnings (touch is never true) ! IF ( TOUCH ) PRINT *,'START_DOF_VALUE:', IG, XYZ !END FUNCTION START_DOF_VALUE_EX_122 !============= End Files for EXAMPLE number 122 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= End Files for EXAMPLE number 123 ============= SUBROUTINE DESCRIBE_EXAMPLE_123 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 123 ***' PRINT *, 'APPLICATION DEPENDENT Galerkin FOR TRANSIENT SOLUTION' PRINT *, 'K*A U,xx - h*P (U - U_ext) - Rho_cp U,t = 0, ' PRINT *, 'conduction plus convective line loss with ' PRINT *, 'U(x,0) = start_value, flux (q*A) or EBC at ends' PRINT *, 'Integrations 1-Euler, 2-Crank-Nicolson, 3-Galerkin 4-L Sq' PRINT *, 'Properties: K_e, A_e, h_e, P_e, Rho_cp, U_ext' END SUBROUTINE DESCRIBE_EXAMPLE_123 SUBROUTINE ELEM_SQ_EX_123 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! 123.my_el_sq_inc ! .............................................................. ! Combined heat conduction through, convection from a bar: ! K*A*U,XX - h*P*(U-U_ext) - Rho_cp U,t = 0 ! Real element properties are: ! 1) K_e = conductivity, BTU/ hr ft F ! 2) A_e = area of bar, ft^2 ! 3) h_e = convection, BTU/ hr ft^2 F ! 4) P_e = perimeter of area A_e, ft ! 5) Rho_cp = mass density * specific heat ! 6) U_ext = external fluid temperature around element REAL(DP) :: DL, DX_DR ! Length, Jacobian REAL(DP), SAVE :: K_e = 1.d0, A_e = 1.d0 ! properties REAL(DP), SAVE :: h_e = 1.d0, P_e = 1.d0 ! properties REAL(DP), SAVE :: Rho_cp = 1.d0, U_ext = 0.d0 ! properties INTEGER :: IQ ! Loops DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL / 2. ! CONSTANT JACOBIAN K_e = GET_REAL_LP (1) ! thermal conductivity A_e = GET_REAL_LP (2) ! area of bar h_e = GET_REAL_LP (3) ! convection coefficent on perimeter P_e = GET_REAL_LP (4) ! perimeter of area A_e Rho_cp = GET_REAL_LP (5) ! external temperature U_ext = GET_REAL_LP (6) ! external temperature E = K_e * A_e ! constitutive array CALL STORE_FLUX_POINT_COUNT ! Save LT_QP, for post & error ! S, C, H_INTG already zeroed DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL DERIVATIVES DLH = GET_DLH_AT_QP (IQ) ! local DGH = DLH / DX_DR ! global ! CONVECTION SOURCE C = C + h_e * P_e * U_ext * H * WT (IQ) * DX_DR ! SQUARE MATRIX, CONDUCTION & CONVECTION S = S + ( K_e * A_e * MATMUL (TRANSPOSE(DGH), DGH) & + h_e * P_e * OUTER_PRODUCT (H, H) ) * WT (IQ) * DX_DR EL_M = EL_M + Rho_cp * OUTER_PRODUCT (H, H) * WT (IQ) * DX_DR ! INTEGRATING FOR CONVECTION LOSS, FOR POST PROCESSING H_INTG = H_INTG + h_e * P_e * H * WT (IQ) * DX_DR ! SAVE FOR FLUX AVERAGING OR POST PROCESSING, B == DGH CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) END DO ! QUADRATURE ! IF ( N_FILE1 > 0) WRITE (N_FILE1) H_INTG, U_ext ! if "post_el" key ! End of application dependent code ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_123 SUBROUTINE POST_PROCESS_ELEM_EX_123 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_123 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! 123.my_post_el_inc ! .............................................................. ! Define any new array or variable types, then give statements ! H_INTG (LT_N) Integral of interpolation functions, H, available ! Linear line element face convection heat loss recover REAL(DP) :: U_ext ! external temperature REAL(DP), SAVE :: Q_LOSS, TOTAL ! Face and total heat loss LOGICAL, SAVE :: FIRST = .TRUE. ! printing IF ( FIRST ) THEN ! first call FIRST = .FALSE. ; WRITE (6, 5) ! print headings 5 FORMAT ('*** CONVECTION HEAT LOSS ***', /, & & 'ELEMENT HEAT_LOST') TOTAL = 0.d0 ! initialize END IF ! first call ! Get previously integrated interpolation function, times ! the convection properties, h_e * P_e, now stored in H_INTG; ! and the surrounding gas temperature, U_ext, that were ! saved in ELEM_SQ_MATRIX. (Indicated by keyword post_el.) ! Real element properties are: ! 1) K_e = conductivity, BTU/ hr ft F ! 2) A_e = area of bar, ft^2 ! 3) h_e = convection, BTU/ hr ft^2 F ! 4) P_e = perimeter of area A_e, ft ! 5) Rho_cp = mass density * specific heat ! 6) U_ext = external fluid temperature around element IF ( N_FILE1 > 0) READ (N_FILE1) H_INTG, U_ext ! if "post_el" ! HEAT LOST : Integral over bar length of hp * (T - T_inf) D (1:LT_N) = D(1:LT_N) - U_ext ! Temp difference at nodes Q_LOSS = DOT_PRODUCT (H_INTG, D) ! Face loss integral TOTAL = TOTAL + Q_LOSS ! Running total PRINT '(I6, ES15.5)', IE, Q_LOSS IF ( IE == N_ELEMS ) PRINT *, 'TOTAL = ', TOTAL ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_123 !============= End Files for EXAMPLE number 123 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 125 ============= SUBROUTINE DESCRIBE_EXAMPLE_125 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 125 ***' PRINT *,'Beam on an elastic foundation with transvers load' PRINT *,'Rho U,tt + EI * U,xxxx + k * U = Q(x), ' PRINT *,'Hermite cubic C1 L2. Real element properties:' PRINT *,'1: EI = Bending stiffness' PRINT *,'2: K = Foundation Bending stiffness' PRINT *,'3: P_1 = Line load at left node for Q(x)' PRINT *,'4: P_2 = Line load at right node for Q(x)' PRINT *,'5: EL_REAL > 4; Rho = mass per unit length' PRINT *,'Point loads allowed. Rho, k & Q may be zero.' END SUBROUTINE DESCRIBE_EXAMPLE_125 SUBROUTINE ELEM_SQ_EX_125 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Beam on an elastic foundation with transvers load ! Rho U,tt + EI * U,xxxx + k * U = Q(x), EI=bending stiffness, ! k = foundation stiffness, Q, Rho =load, mass per unit length ! Note: The C_1 and C_2 elements in MODEL use unit coordinates ! so the quadrature rule data must be converted REAL(DP) :: DL, DX_DR ! Length, Jacobian REAL(DP) :: H_V (LT_FREE), D2LH_V (LT_FREE) REAL(DP) :: UNIT_WT, UNIT_PT ! QP Conversions REAL(DP) :: EI, K, P_1, P_2, Q, RHO ! Properties INTEGER :: IQ ! Loops DL = COORD (LT_N, 1) - COORD (1, 1) ! LENGTH DX_DR = DL ! CONSTANT JACOBIAN ! GET PROPERTIES EI = GET_REAL_LP (1) ! Bending stiffness K = GET_REAL_LP (2) ! Foundation P_1 = GET_REAL_LP (3) ! Line load at left P_2 = GET_REAL_LP (4) ! Line load at right RHO = 0.d0 ! mass per unit length IF ( EL_REAL > 4 ) RHO = GET_REAL_LP (5) EL_M = 0.d0 E (1, 1) = EI IF ( U_FLUX > 0 ) WRITE (U_FLUX) LT_QP ! for SCP or post-process DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES UNIT_WT = WT (IQ) * 0.5d0 ! Weight UNIT_PT = (PT (1, IQ ) + 1.d0) * 0.5d0 ! Location ! GET GEOMETRY FUNCTIONS, AND X-COORD H = (/ (1.d0 - UNIT_PT), UNIT_PT /) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! INTERPOLATE FOR LINE LOAD Q = H (1) * P_1 + H (2) * P_2 ! MULTIPLE COMPONENT INTERPOLATION AND DERIVATIVES CALL SHAPE_C1_L (UNIT_PT, DL, H_V) ! Foundation or load CALL DERIV2_C1_L (UNIT_PT, DL, D2LH_V) ! Bending ! SQUARE MATRIX S = S + ( OUTER_PRODUCT (D2LH_V, D2LH_V) * EI & + OUTER_PRODUCT (H_V, H_V ) * K ) * UNIT_WT * DX_DR ! SOURCE VECTOR C = C + H_V * Q * UNIT_WT * DX_DR ! MASS MATRIX IF ( RHO > 0.d0 ) THEN EL_M = EL_M + OUTER_PRODUCT (H_V, H_V)* RHO * UNIT_WT * DX_DR END IF IF ( U_FLUX > 0 ) WRITE (U_FLUX) XYZ, E, D2LH_V ! for post-proc END DO ! QUADRATURE ! End of application dependent code ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_125 !============= End Files for EXAMPLE number 125 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 136 ============= SUBROUTINE DESCRIBE_EXAMPLE_136 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 136 ***' PRINT *, 'Dynamic or Eigensolution or Statics for the axial' PRINT *, 'or torsional response of a linear bar' PRINT *, 'Equation: K*A U,xx + Rho*A U,tt + Q_e = 0,' PRINT *, 'U = displacement, K = stiffness, A = area' PRINT *, 'Rho = mass density, Q_e = source per unit length' PRINT *, '1 *---(K_e, A_e, Rho_e, Q_e)---* 2, Element in x' PRINT *, 'Prop: 1 2 3 4' END SUBROUTINE DESCRIBE_EXAMPLE_136 SUBROUTINE ELEM_SQ_EX_136 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! For required REAL (DP) :: S (LT_FREE, LT_FREE) ! and optional REAL (DP) :: C (LT_FREE) ! .............................................................. ! Dynamic axial or torsional response of a linear bar ! Equation: K*A U,xx + Rho*A U,tt + Q_e = 0, ! U = displacement, K = stiffness, A = area ! Rho = mass density, Q_e = source per unit length ! 1 *---(K_e, A_e, Rho_e, Q_e)---* 2, Element in x REAL(DP) :: DL ! Length REAL(DP) :: K_e, A_e, Rho_e, Q_e ! properties DL = ABS(COORD (2, 1) - COORD (1, 1)) K_e = GET_REAL_LP (1) ! stiffness A_e = GET_REAL_LP (2) ! area of bar Rho_e = GET_REAL_LP (3) ! mass density Q_e = GET_REAL_LP (4) ! source per unit volume S = K_e * A_e / DL * RESHAPE ((/ 1, -1, -1, 1 /), (/2,2/)) EL_M = Rho_e * A_e * DL * RESHAPE ((/2, 1, 1, 2 /), (/2,2/)) / 6.d0 C = Q_e * DL * (/ 1, 1 /) * 0.5d0 ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) !b STOP 'ERROR: NO SOURCE AT ELEM_SQ_EX_136' END SUBROUTINE ELEM_SQ_EX_136 !============= End Files for EXAMPLE number 136 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 137 ============= SUBROUTINE DESCRIBE_EXAMPLE_137 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 137 ***' PRINT *,'Dynamic axial or torsional response of a linear bar' PRINT *,'Equation: K*A U,xx + Rho*A U,tt + Q_e = 0,' PRINT *,'U = displacement, K = stiffness, A = area' PRINT *,'Rho = mass density, Q_e = source per unit length' PRINT *,'1 *---(K_e, A_e, Rho_e, Q_e)---* LT_N, Axial element in x' PRINT *,'1 *---(G_e, I_e, Rho_e, Q_e)---* LT_N, Torsional element in x' PRINT *,'Prop: 1 2 3 4' PRINT *,'Error estimates available for static and eigen-problem' END SUBROUTINE DESCRIBE_EXAMPLE_137 SUBROUTINE ELEM_SQ_EX_137 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Dynamic, Eigen, or Static axial or torsional response of a bar ! K*A U,xx + Rho*A U,tt + Q_e = 0, by numerical integration ! U = displacement, K = stiffness, A = area ! Rho = mass density, Q_e = source per unit length ! 1 *---(K_e, A_e, Rho_e, Q_e)---* LT_N, Axial element in x ! 1 *---(G_e, I_e, Rho_e, Q_e)---* LT_N, Torsional element in x REAL(DP) :: DL, DX_DN ! Length, Jacobian REAL(DP) :: K_e, A_e, Rho_e, Q_e ! properties INTEGER :: IQ ! Loops DL = ABS(COORD (LT_N, 1) - COORD (1, 1)) ! length K_e = GET_REAL_LP (1) ! elastic modulus; shear modulus A_e = GET_REAL_LP (2) ! area of bar; inertia of bar Rho_e = GET_REAL_LP (3) ! mass density Q_e = GET_REAL_LP (4) ! source per unit volume; 0 DX_DN = DL / 2. ! CONSTANT JACOBIAN E = K_e * A_e ! CONSTANT E CALL STORE_FLUX_POINT_COUNT ! Save LT_QP for post-processing DO IQ = 1, LT_QP ! LOOP OVER QUADRATURES ! GET INTERPOLATION FUNCTIONS, AND X-COORD H = GET_H_AT_QP (IQ) XYZ = MATMUL (H, COORD) ! ISOPARAMETRIC ! LOCAL AND GLOBAL DERIVATIVES, B = DGH DLH = GET_DLH_AT_QP (IQ) DGH = DLH / DX_DN ! STIFFNESS AND MASS MATRICES S = S + MATMUL (TRANSPOSE(DGH), DGH) * WT (IQ) * DX_DN & * K_e * A_e EL_M = EL_M + OUTER_PRODUCT (H, H) * WT (IQ) * DX_DN & * Rho_e * A_e C = C + H * Q_e * WT (IQ) * DX_DN ! SOURCE VECTOR CALL STORE_FLUX_POINT_DATA (XYZ, E, DGH) ! for post-processing END DO ! QUADRATURE LOOP ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) !b STOP 'ERROR: NO SOURCE AT ELEM_SQ_EX_137' END SUBROUTINE ELEM_SQ_EX_137 !============= End Files for EXAMPLE number 137 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 201 ============= SUBROUTINE DESCRIBE_EXAMPLE_201 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE = 201 PRINT *, "*** DESCRIPTIONS OF EXAMPLE ", EXAMPLE, " ***" PRINT *, "PLANE_STRESS ANALYSIS, NON-ISOPARAMETRIC" PRINT *, "----------------------------------------" PRINT *, " PROP(1) = YOUNG'S MODULUS OF ELASTICITY " PRINT *, " PROP(2) = POISSON'S RATIO " PRINT *, " PROP(3) = YIELD STRESS, IF PRESENT" PRINT *, " STRESS AND STRAIN COMPONENT ORDER: XX, YY, XY, " PRINT *, " SO N_R_B = 3, Von Mises' also output'" END SUBROUTINE DESCRIBE_EXAMPLE_201 SUBROUTINE ELEM_SQ_EX_201 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE = 201 Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! PLANE_STRESS ANALYSIS, NON-ISOPARAMETRIC ! ---------------------------------------- ! EL_PROP(1) = YOUNG'S MODULUS OF ELASTICITY ! EL_PROP(2) = POISSON'S RATIO ! EL_PROP(3) = YIELD STRESS, IF PRESENT ! STRESS AND STRAIN COMPONENT ORDER: XX, YY, XY, SO N_R_B = 3 INTEGER :: IP ! loops REAL(DP), SAVE :: Y, PR ! last material set REAL(DP) :: DET, DET_WT, THICK CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !b !---> DEFINE CONSTANT PROPERTIES IF ( DEBUG_PROPERTY ) PRINT *, 'Entering ELEM_SQ_EX_201 ' Y = GET_REAL_LP (1) ; PR = GET_REAL_LP (2) ; THICK = 1 IF ( AREA_THICK /= 1.d0 ) THICK = AREA_THICK ! FORM THE CONSTITUTIVE MATRIX (OR GET_APPLICATION_E_MATRIX ) CALL PLANE_STRESS_E_MATRIX (Y, PR, E) !b !b E = E * THICK B = 0.0d0 DO IP = 1, LT_QP ! NUMERICAL INTEGRATION LOOP G = GET_G_AT_QP (IP) ! GEOMETRY INTERPOLATIONS GEOMETRY = COORD (1:LT_GEOM,:) ! GEOMETRY NODES XYZ = MATMUL ( G, GEOMETRY ) ! COORDINATES OF POINT DLG = GET_DLG_AT_QP (IP) ! GEOMETRIC DERIVATIVES AJ = GEOMETRIC_JACOBIAN () ! JACOBIAN CALL INVERT_2BY2 (AJ, AJ_INV, DET) ! INVERSE, DET DET_WT = DET * WT (IP) * THICK !b H = GET_H_AT_QP (IP) ! SCALAR INTERPOLATIONS DLH = GET_DLH_AT_QP (IP) ! SCALAR DERIVATIVES DGH = MATMUL ( AJ_INV, DLH ) ! PHYSICAL DERIVATIVES !---> FORM STRAIN DISPLACEMENT, B (OR GET_APPLICATION_B_MATRIX) CALL B_MATRIX_PLANE_ELASTIC (LT_N, N_SPACE, N_G_DOF, DGH, & N_R_B, B) ! EVALUATE ELEMENT MATRICES S = S + DET_WT * MATMUL (TRANSPOSE(B), MATMUL (E, B)) ! SAVE PT, CONSTITUTIVE & STRAIN_DISP FOR POST_PROCESS & SCP CALL STORE_FLUX_POINT_DATA (XYZ, E, B) !b END DO ! Over quadrature points ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_201 SUBROUTINE POST_PROCESS_ELEM_EX_201 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_201 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE = 201 Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! PLANE_STRESS ANALYSIS, NON-ISOPARAMETRIC ! ---------------------------------------- ! EL_PROP(1) = YOUNG'S MODULUS OF ELASTICITY ! EL_PROP(2) = POISSON'S RATIO ! EL_PROP(3) = YIELD STRESS, IF PRESENT ! STRESS AND STRAIN COMPONENT ORDER: XX, YY, XY, (VON MISES) INTEGER :: J, N_IP, IO_TEST REAL(DP), SAVE :: YIELD ! FAILURE DATA IF ( IE == 1 ) THEN ! PRINT TITLES & INITIALIZE !!b Rex special !open (44, file = 'von_mises_qp.tmp', status = 'unknown', & !action = 'write', iostat = IO_TEST) !IF ( IO_TEST > 0 ) PRINT *,'von_mises_qp.tmp failed to open' !open (45, file = 'von_mises_qp_all.tmp', status = 'unknown', & !action = 'write', iostat = IO_TEST) !IF ( IO_TEST > 0 ) PRINT *,'von_mises_qp_all.tmp failed to open' !!b REx STRAIN = 0.d0 ; STRAIN_0 = 0.d0 ! INITIALIZE ALL OF "STRAIN" !b IF ( N_LP_FLO > 2 ) THEN ! INITIALIZE YIELD IF ( EL_REAL > 2 ) THEN ! INITIALIZE YIELD IF ( DEBUG_PROPERTY ) PRINT *, 'Entering POST_PROCESS_ELEM_EX_201 ' YIELD = GET_REAL_LP (3) ELSE YIELD = HUGE (1.d0) END IF ! YIELD DATA WRITE (6, 50) ; 50 FORMAT ( /, & '*** STRESSES AT INTEGRATION POINTS ***', /, & ' COORDINATES STRESSES', /, & 'POINT X Y XX YY', /, & 'POINT XY EFFECTIVE') END IF ! NEW HEADINGS WRITE (6, * ) ' ELEMENT NUMBER ', IE CALL READ_FLUX_POINT_COUNT (N_IP) !b DO J = 1, N_IP ! AT QUADRATURE POINTS CALL READ_FLUX_POINT_DATA (XYZ, E, B) ! PT, PROP, STRAIN_DISP ! MECHANICAL STRAINS & STRESSES STRAIN (1:N_R_B) = MATMUL (B, D) ! STRAINS AT THE POINT STRESS (1:N_R_B) = MATMUL (E, STRAIN (1:N_R_B)) ! (see HOOKE) ! VON_MISES FAILURE CRITERION (EFFECTIVE STRESS) STRESS (4) = SQRT ( (STRESS (1) - STRESS (2) ) **2 & + (STRESS (2)) **2 + (STRESS (1)) **2 & + 6.d0 * STRESS (3) **2 ) * 0.7071068d0 IF ( STRESS (4) >= YIELD ) PRINT *, & 'WARNING: FAILURE CRITERION EXCEEDED IN ELEMENT =', IE ! LIST STRESSES AND FAILURE CRITERION AT POINT WRITE (6, 52) J, XYZ (1:2), STRESS (1:2) WRITE (6, 51) J, STRESS (3:4) 52 FORMAT ( I3, 2(1PE11.3), 5(1PE14.5) ) 51 FORMAT ( I3, 22X, 5(1PE14.5) ) !!b Rex special !WRITE (44, '(6ES12.4)') XYZ (1:2), STRESS (4) !b !WRITE (45, '(6ES12.4)') XYZ (1:2), STRESS (1:4) !b !!b Rex special END DO ! AT QUADRATURE POINTS ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_201 ! =============== End Files for EXAMPLE number 201 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 202 ============= SUBROUTINE DESCRIBE_EXAMPLE_202 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 202 ***' PRINT *, 'ANISOTROPIC POISSON EQUATION IN TWO DIMENSIONS' PRINT *, 'K_xx U,xx + 2K_xy U,xy + K_yy U,yy + Q = 0' PRINT *, 'PROP(1) = CONDUCTIVITY K_XX ' PRINT *, 'PROP(2) = CONDUCTIVITY K_YY' PRINT *, 'PROP(3) = CONDUCTIVITY K_XY' PRINT *, 'PROP(4) = SOURCE PER UNIT VOLUME, Q' PRINT *, 'or use my_exact_source_inc when EXACT_CASE = 0' IF ( DATA_SET == 1 ) THEN PRINT *, ' ' PRINT *, 'DATA_SET 1 is EXACT_CASE 2,' PRINT *, 'Solution of the 2-D test case used by Lakhany & Whiteman' PRINT *, '(u,xx+u,yy) = -(2 + pi_sq * (1-x^2)) * Sin (pi y)' PRINT *, 'on (-1,-1)X(1,1). Exact u(x, y) = (1 - x^2) * Sin (pi y)' ELSE IF ( DATA_SET == 2 ) THEN PRINT *, ' ' PRINT *, 'DATA_SET 2 is EXACT_CASE 5' PRINT *, 'Poisson Equation on an segment of a circular' PRINT *, 'annulus in the first quadrant from r=1 to r=2' PRINT *, 'T(X,Y) = 10 - X^2 Y^2, exact. Dirchlet BC on all edges' ELSE IF ( DATA_SET == 3 ) THEN PRINT *, ' ' PRINT *, 'DATA_SET 3 is EXACT_CASE 5 with normal flux on one edge' PRINT *, 'Poisson Equation on an segment of a circular' PRINT *, 'annulus in the first quadrant from r=1 to r=2' PRINT *, 'T(X,Y) = 10 - X^2 Y^2, exact.' PRINT *, ' ' ELSE IF ( DATA_SET == 4 ) THEN PRINT *, 'DATA_SET 4 is EXACT_CASE 8,' PRINT *, 'Patch Test with Constant 2nd Derivs' PRINT *, 'u = x + 5y + 2x^2 + 3xy + 4y^2' PRINT *, 'u,xx = 4 u,xy=u,yx = 3 u,yy = 8; Q = 12 or 18' END IF END SUBROUTINE DESCRIBE_EXAMPLE_202 SUBROUTINE E_MATRIX_EX_202 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE, THIS_EL Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) REAL(DP) :: K_XX, K_YY, K_XY !--> DEFINE ELEMENT PROPERTIES K_XY = 0 K_XX = GET_REAL_LP (1) ; K_YY = K_XX ; K_XY = 0 ! isotropic IF ( EL_REAL > 1 ) K_YY = GET_REAL_LP (2) ! orthotropic IF ( EL_REAL > 2 ) K_XY = GET_REAL_LP (3) ! anisotropic CALL POISSON_ANISOTROPIC_2D_E_MATRIX (K_XX, K_YY, K_XY, E) ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ (1) END SUBROUTINE E_MATRIX_EX_202 SUBROUTINE ELEM_SQ_EX_202 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_SOURCE IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! ANISOTROPIC POISSON EQUATION IN TWO DIMENSIONS ! VIA NUMERICALLY INTEGRATED ELEMENTS REAL(DP) :: CONST, DET, THICK ! integration REAL(DP) :: K_XX, K_YY, K_XY, SOURCE ! data INTEGER :: IP ! counter ! K_xx U,xx + 2K_xy U,xy + K_yy U,yy + Q = 0 ! PROPERTY(1) = CONDUCTIVITY K_XX ; PROPERTY(2) = CONDUCTIVITY K_YY ! PROPERTY(3) = CONDUCTIVITY K_XY ! usually zero ! PROPERTY(4) = SOURCE PER UNIT VOLUME, or use my_exact_source_inc ! PROPERTY(5) = THICKNESS defaults to 1 !--> DEFINE ELEMENT PROPERTIES THICK = 1 ; SOURCE = 0 ; XYZ = 0 IF ( SCALAR_SOURCE /= 0.d0 ) SOURCE = SCALAR_SOURCE ! global Q IF ( EL_REAL > 3 ) SOURCE = GET_REAL_LP (4) ! local Q IF ( EL_REAL > 4 ) THICK = GET_REAL_LP (5) ! constant tw CALL E_MATRIX_EX_202 (THIS_EL, XYZ, E) ! XYZ not used !b POISSON_ANISOTROPIC_2D_E_MATRIX (K_XX, K_YY, K_XY, E) ! STORE NUMBER OF POINTS FOR FLUX CALCULATIONS CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !--> NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT ! FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IP) * THICK ! EVALUATE GLOBAL DERIVATIVES, DGH == B DGH = MATMUL (AJ_INV, DLH) ! Physical gradient B = COPY_DGH_INTO_B_MATRIX (DGH) ! B = DGH ! VARIABLE VOLUMETRIC SOURCE, via keyword use_exact_source ! Defaults to file my_exact_source_inc if no exact_case key IF ( USE_EXACT_SOURCE ) CALL & ! analytic Q SELECT_EXACT_SOURCE (XYZ, SOURCE) ! via exact_case key C = C + CONST * SOURCE * H ! source resultant ! CONDUCTION SQUARE MATRIX (THICKNESS IN E) S = S + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING !b CALL STORE_FLUX_POINT_DATA (XYZ, (E * THICK), B) CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO ! end 202.my_el_sq_inc_2 Sun Mar 17 17:38:42 CST 2002 ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_202 SUBROUTINE MIXED_SQ_EX_202 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE MIXED_BC SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_ROBIN_DATA IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** MIXED_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Mixed or Robin boundary condition, Standard form: ! K_n * U,n + ROBIN_1_SEG * U + ROBIN_2_SEG = 0 INTEGER :: IP REAL(DP) :: CONST, DET, THICK THICK = 1.d0 ; IF ( LT_PARM < 2 ) THICK = ROBIN_THICK ! pt or line IF ( CONVECTION ) THEN ! constant convection all segments ROBIN_1_SEG = CONVECT_COEF ROBIN_2_SEG = CONVECT_COEF * CONVECT_TEMP THICK = CONVECT_THICK END IF ! Convection IF ( LT_N > 1 ) THEN ! Not a point value DO IP = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IP) ! BOUNDARY INTERPOLATION FUNCTIONS ! FIND GLOBAL COORD, XYZ = H*COORD (ISOPARAMETRIC) XYZ = MATMUL (H, COORD) ! FIND LOCAL DERIVATIVES DLH = GET_DLH_AT_QP (IP) ! FORM DETERMINATE OF GENERALIZED JACOBIAN DET = PARM_GEOM_METRIC (DLH, COORD) !b actually DLG CONST = DET * WT(IP) * THICK ! GET VARIABLE ROBIN_DATA COMPONENTS, from exact_case IF ( USE_EXACT ) CALL SELECT_EXACT_ROBIN_DATA & (XYZ, ROBIN_1_SEG, ROBIN_2_SEG) S = S + ROBIN_1_SEG * CONST * OUTER_PRODUCT (H, H) ! Sq matrix C = C + ROBIN_2_SEG * CONST * H ! Source vec END DO ELSE ! This is a point value ! GET ROBIN_DATA COMPONENTS IF ( USE_EXACT ) CALL SELECT_EXACT_ROBIN_DATA & (COORD (1, :), ROBIN_1_SEG, ROBIN_2_SEG) S (1, 1) = ROBIN_1_SEG * THICK C (1) = ROBIN_2_SEG * THICK !b sign ?? xxx END IF ! boundary segment type ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE MIXED_SQ_EX_202 SUBROUTINE SEG_COL_EX_202 (E, H_INTG, PRT_L_PT, PRT_MAT,& L_PT_PROP, IE, FLUX) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE FLUX SEGMENT COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Geometric_Properties Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_NORMAL_FLUX IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! OPTIONAL FLUX VALUES IF BOUNDARY SEGMENT ELEMENT REAL(DP), INTENT(IN) :: FLUX (L_B_N, N_G_FLUX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & XYZ (N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** SEG_COL_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! Given normal flux on an element face or edge: ! Standard form: -K_n * U,n = Q_NORMAL_SEG (in System_Constants) INTEGER :: IP REAL(DP) :: CONST, DET IF ( N_SPACE > 1 ) THEN ! Not a point value DO IP = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IP) ! BOUNDARY INTERPOLATION FUNCTIONS ! FIND GLOBAL COORD, XYZ = H*COORD (ISOPARAMETRIC) XYZ = MATMUL (H, COORD) ! FIND LOCAL DERIVATIVES DLH = GET_DLH_AT_QP (IP) ! FORM DETERMINATE OF GENERALIZED JACOBIAN DET = PARM_GEOM_METRIC (DLH, COORD) !b actually DLG CONST = DET * WT(IP) ! GET NORMAL FLUX COMPONENT IF ( USE_EXACT_FLUX ) THEN ! use exact_case CALL SELECT_EXACT_NORMAL_FLUX (XYZ, Q_NORMAL_SEG) ELSE IF ( FLUX_NORMAL ) THEN ! constant flux ! Q_NORMAL_SEG = Q_NORMAL_SEG ! via keyword ELSE ! use application analytic !b CALL APPLICATION_NORMAL_FLUX (XYZ, Q_NORMAL_SEG) !b xxx END IF ! via case C = C + Q_NORMAL_SEG * CONST * H ! Source vector END DO ELSE ! This is a point value XYZ (:) = COORD (1, :) ! GET NORMAL FLUX COMPONENT IF ( USE_EXACT_FLUX ) THEN ! use exact_case CALL SELECT_EXACT_NORMAL_FLUX (XYZ, Q_NORMAL_SEG) ELSE IF ( FLUX_NORMAL ) THEN ! constant flux ! Q_NORMAL_SEG = Q_NORMAL_SEG ! via keyword ELSE ! use application analytic !b CALL APPLICATION_NORMAL_FLUX (XYZ, Q_NORMAL_SEG) !b xxx END IF ! via case C (1) = Q_NORMAL_SEG END IF ! boundary segment type ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, FLUX END SUBROUTINE SEG_COL_EX_202 ! ============= End Files for EXAMPLE number 202 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 203 ============= SUBROUTINE DESCRIBE_EXAMPLE_203 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 203 ***' PRINT *,'PLANE FRAME ANALYSIS, N_SPACE = 2, NOD_PER_EL = 2,' PRINT *,'N_G_DOF = 3, N_LP_FLO = 3, N_EL_FRE = 6' PRINT *,' REAL ELEMENT PROPERTIES:' PRINT *,'1 = CROSS_SECTIONAL AREA 1 (e) 2' PRINT *,'2 = MOMENT OF INERTIA P_1 *------ A, E, I ------* P_2' PRINT *,'3 = MODULUS OF ELASTICITY' PRINT *,'4 = DISTRIBUTED LOAD, NODE 1 (TO RIGHT FROM NODE 1 TO 2)' PRINT *,'5 = DISTRIBUTED LOAD, NODE 2 (TO RIGHT FROM NODE 1 TO 2)' PRINT *,'6 = Optional mass effect: MASS DENSITY' END SUBROUTINE DESCRIBE_EXAMPLE_203 SUBROUTINE ELEM_SQ_EX_203 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! APPLICATION: PLANE FRAME WITH REAL ELEMENT PROPERTIES: ! 1 = CROSS_SECTIONAL AREA 1 (e) 2 ! 2 = MOMENT OF INERTIA P_1 *------ A, E, I --------* P_2 ! 3 = YOUNG'S MODULUS OF ELASTICITY ! 4,5 = DISTRIBUTED LOAD, NODE 1,2 (TO RIGHT FROM NODE 1 TO 2) ! CM, SM = MEMBER LOCAL RESULTANT LOAD VECTOR & STIFFNESS MATRIX ! T, MM = MEMBER TRANSFORMATION MATRIX & MASS MATRIX ! Automatic arrays REAL(DP) :: SM (LT_FREE, LT_FREE), T (LT_FREE, LT_FREE) REAL(DP) :: MM (LT_FREE, LT_FREE), CM (LT_FREE), DX, DY, FL REAL(DP) :: A, ZI, YM, RHO, RAL, EDL, BETA, P1, P2, CX, CY !--> DEFINE ELEMENT PROPERTIES (for keyword: el_real 5) A = GET_REAL_LP (1) ; ZI = GET_REAL_LP (2) ! GEOMETRIC YM = GET_REAL_LP (3) ! MATERIAL P1 = GET_REAL_LP (4) ; P2 = GET_REAL_LP (5) ! LINE LOAD !--> FIND MEMBER LENGTH AND DIRECTION COSINES DX = COORD (2, 1) - COORD (1, 1) ! X length DY = COORD (2, 2) - COORD (1, 2) ! Y length FL = SQRT (DX * DX + DY * DY) ! total length CX = DX / FL ; CY = DY / FL ! direction cosines EDL = YM / FL ; BETA = ZI / FL ! section constants CM = 0.d0 ; SM = 0.d0 ; T = 0.d0 ! Initialize local arrays !--> DEFINE NON-ZERO TERMS IN STIFFNESS MATRIX SM (1, 1) = A * EDL ; SM (2, 2) = 12.d0 * EDL * BETA / FL SM (2, 3) = 6.d0 * EDL * BETA ; SM (3, 2) = SM (2, 3) SM (3, 3) = 4.d0 * EDL * ZI ; SM (1, 4) = - A * EDL SM (4, 1) = SM (1, 4) ; SM (4, 4) = A * EDL SM (2, 5) = - SM (2, 2) ; SM (5, 2) = SM (2, 5) SM (3, 5) = - SM (2, 3) ; SM (5, 3) = SM (3, 5) SM (5, 5) = SM (2, 2) ; SM (2, 6) = SM (2, 3) SM (6, 2) = SM (2, 6) ; SM (3, 6) = 2.d0 * EDL * ZI SM (6, 3) = SM (3, 6) ; SM (5, 6) = - SM (2, 3) SM (6, 5) = SM (5, 6) ; SM (6, 6) = 4.d0 * EDL * ZI !--> DEFINE NON-ZERO LOCAL LOADS RESULTANTS CM (2) = -FL * (7.d0 * P1 + 3.d0* P2) / 20.d0 CM (5) = -FL * (3.d0 * P1 + 7.d0* P2) / 20.d0 CM (3) = -FL * FL * ( P1 + 2.d0 * P2 / 3.d0) / 20.d0 CM (6) = -FL * FL * (-P2 - 2.d0 * P1 / 3.d0) / 20.d0 !--> DEFINE NON-ZERO TERMS IN TRANSFORMATION MATRIX T (1, 1) = CX ; T (2, 1) = -CY ; T (1, 2) = CY T (2, 2) = CX ; T (3, 3) = 1.d0 ; T (4, 4) = CX T (5, 4) = -CY ; T (4, 5) = CY ; T (5, 5) = CX T (6, 6) = 1.d0 !--> TRANSFORM TO GLOBAL COORDINATES, S = (T)'*SM*T S = MATMUL (TRANSPOSE(T), MATMUL (SM, T)) C = MATMUL (TRANSPOSE(T), CM) ! Optional mass effect: 6 = MASS DENSITY IF ( EL_REAL > 5 ) THEN RHO = GET_REAL_LP (6) ! mass density RAL = RHO * A * FL / 420 ; MM = 0.d0 MM (1, 1) = 140 * RAL ; MM (4, 1) = 70 * RAL ! axial MM (1, 4) = 70 * RAL ; MM (4, 4) = 140 * RAL ! axial MM (2, 2) = 156 * RAL ; MM (3, 2) = 22 * FL * RAL ! beam MM (5, 2) = 54 * RAL ; MM (6, 2) = -13 * FL * RAL ! beam MM (2, 3) = 22 * FL * RAL ; MM (3, 3) = 4 * FL * FL * RAL ! beam MM (5, 3) = 13 * FL * RAL ; MM (6, 3) = -3 * FL * FL * RAL ! beam MM (2, 5) = 54 * RAL ; MM (3, 5) = 13 * FL * RAL ! beam MM (5, 5) = 156 * RAL ; MM (6, 5) = -22 * FL * RAL ! beam MM (2, 6) = -13 * FL * RAL ; MM (3, 6) = -3 * FL * FL * RAL ! beam MM (5, 6) = -22 * FL * RAL ; MM (6, 6) = 4 * FL * FL * RAL ! beam EL_M = MATMUL (TRANSPOSE(T), MATMUL (MM, T)) ! Rotated END IF ! Mass matrix too ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_203 ! ============= End Files for EXAMPLE number 203 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 204 ============= SUBROUTINE DESCRIBE_EXAMPLE_204 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 204 ***' PRINT *,'ANISOTROPIC POISSON EQUATION IN TWO DIMENSIONS' PRINT *,'HARD CODED 3 NODE TRIANGLE WITH THICKNESS = 1' PRINT *,'K_xx U,xx + 2K_xy U,xy + K_yy U,yy + Q = 0' PRINT *,'PROP(1) = CONDUCTIVITY K_XX' PRINT *,'PROP(2) = CONDUCTIVITY K_YY' PRINT *,'PROP(3) = CONDUCTIVITY K_XY' PRINT *,'PROP(4) = SOURCE PER UNIT VOLUME, Q' PRINT *,'PROP(5) = THICKNESS (DEFAULT 1.0)' PRINT *,'Convection: -K_n * U,n = convect_coef*( U - convect_temp)' PRINT *,'input as keywords if constant, or as optional mixed' PRINT *,'properties: 1=convect_coef, 2=convect_temp for each segment' END SUBROUTINE DESCRIBE_EXAMPLE_204 SUBROUTINE ELEM_SQ_EX_204 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! ANISOTROPIC POISSON EQUATION IN TWO DIMENSIONS, T3 ! Linear Triangle, K_xx U,xx + 2 K_xy U,xy + K_yy U,yy + Q = 0 REAL(DP) :: X_I, X_J, X_K, Y_I, Y_J, Y_K ! Global coordinates REAL(DP) :: A_I, A_J, A_K, B_I, B_J, B_K ! Standard geometry REAL(DP) :: C_I, C_J, C_K, X_CG, Y_CG, TWO_A ! Standard geometry REAL(DP) :: THICK ! Element thickness ! DEFINE NODAL COORDINATES, CCW: I, J, K X_I = COORD (1,1) ; X_J = COORD (2,1) ; X_K = COORD (3,1) Y_I = COORD (1,2) ; Y_J = COORD (2,2) ; Y_K = COORD (3,2) ! DEFINE CENTROID COORDINATES (QUADRATURE POINT) X_CG = (X_I + X_J + X_K)/3.d0 ; Y_CG = (Y_I + Y_J + Y_K)/3.d0 ! GEOMETRIC PARAMETERS: H_I (X,Y) = (A_I + B_I*X + C_I*Y)/TWO_A A_I = X_J * Y_K - X_K * Y_J ; B_I = Y_J - Y_K ; C_I = X_K - X_J A_J = X_K * Y_I - X_I * Y_K ; B_J = Y_K - Y_I ; C_J = X_I - X_K A_K = X_I * Y_J - X_J * Y_I ; B_K = Y_I - Y_J ; C_K = X_J - X_I ! CALCULATE TWICE ELEMENT AREA TWO_A = A_I + A_J + A_K ! = B_J*C_K - B_K*C_J also ! DEFINE 2 BY 3 GRADIENT MATRIX, B (= DGH) B (1, 1:3) = (/ B_I, B_J, B_K /) / TWO_A ! DH/DX, row 1 B (2, 1:3) = (/ C_I, C_J, C_K /) / TWO_A ! DH/DY, row 2 ! DEFINE PROPERTIES: 1-K_xx, 2-K_yy, 3-K_xy, 4-Source E (1, 1) = GET_REAL_LP (1) ; E (1, 2) = GET_REAL_LP (3) E (2, 2) = GET_REAL_LP (2) ; E (2, 1) = E (1, 2) ; THICK = 1 IF ( EL_REAL >= 5 ) THICK = GET_REAL_LP (5) E = E * THICK ! for proper flux recovery ! CONDUCTION MATRIX, WITH CONSTANT JACOBIAN S = MATMUL ( TRANSPOSE (B), MATMUL (E, B) ) * TWO_A * 0.5d0 ! SOURCE VECTOR: C(1:3) = SOURCE_PER_UNIT_AREA * AREA / 3 C = GET_REAL_LP (4) * THICK * TWO_A / 6.d0 ! SAVE ONE POINT RULE TO AVERAGING, OR ERROR ESTIMATOR LT_QP = 1 ; CALL STORE_FLUX_POINT_COUNT ! Save LT_QP CALL STORE_FLUX_POINT_DATA ( (/ X_CG, Y_CG /), E, B ) ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_204 SUBROUTINE SEG_COL_EX_204 (E, H_INTG, PRT_L_PT, PRT_MAT,& L_PT_PROP, IE, FLUX) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE FLUX SEGMENT COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Geometric_Properties Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! OPTIONAL FLUX VALUES IF BOUNDARY SEGMENT ELEMENT REAL(DP), INTENT(IN) :: FLUX (L_B_N, N_G_FLUX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & XYZ (N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** SEG_COL_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! Given normal flux on a straight boundary segment (BS) edge: ! Standard form: -K_n * U,n = Q_NORMAL_SEG ! where Q_NORMAL_SEG is from control keyword normal_flux, or ! optional flux segment real properties: 1-thickness, 2-flux REAL(DP) :: EDGE_L, THICK ! Edge length, thickness (property 1) !b new version puts normal flux first, thick optional second ! Get the edge length, and thickness of edge THICK = 1 ! Default flux segment real property # 1 IF ( SEG_REAL > 0 ) THICK = GET_REAL_SP (1) EDGE_L = SQRT ( (COORD(2,1) - COORD(1,1)) **2 & + (COORD(2,2) - COORD(1,2)) **2 ) ! Get normal flux from keyword, or segment property IF ( SEG_REAL > 1 ) Q_NORMAL_SEG = GET_REAL_SP (2) C (1) = Q_NORMAL_SEG * THICK * EDGE_L / 2 C (2) = Q_NORMAL_SEG * THICK * EDGE_L / 2 ! End of application dependent code 204.my_seg_col_inc ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, FLUX END SUBROUTINE SEG_COL_EX_204 SUBROUTINE MIXED_SQ_EX_204 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE MIXED_BC SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** MIXED_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new array or variable types, then give statements ! Global CONVECT_COEF set by keyword convect_coef is available ! Global CONVECT_TEMP set by keyword convect_temp is available ! Standard form: -K_n * U,n = CONVECT_COEF ( U - CONVECT_TEMP) ! Linear Triangle Boundary Face Convection Matrices REAL(DP) :: X_I, X_J, X_K, Y_I, Y_J, Y_K ! Global coordinates REAL(DP) :: A_I, A_J, A_K, TWO_A ! Standard geometry ! or Linear Line Boundary Face Convection Matrices REAL(DP) :: L_IJ, THICK ! Line length ! Get convection data from keyword or optional properties THICK = CONVECT_THICK ! default = 1 IF ( MIXED_REAL > 0 ) THEN ! override keyword CONVECT_COEF = GET_REAL_MX (1) ! convection coefficient CONVECT_TEMP = GET_REAL_MX (2) ! convection temperature END IF ! properties supplied IF ( LT_PARM == 2 ) THEN ! face convection ! DEFINE NODAL COORDINATES, CCW: I, J, K X_I = COORD (1,1) ; X_J = COORD (2,1) ; X_K = COORD (3,1) Y_I = COORD (1,2) ; Y_J = COORD (2,2) ; Y_K = COORD (3,2) ! GEOMETRIC PARAMETERS, TWICE ELEMENT AREA A_I = X_J * Y_K - X_K * Y_J ; A_J = X_K * Y_I - X_I * Y_K A_K = X_I * Y_J - X_J * Y_I ; TWO_A = A_I + A_J + A_K ! FACE CONVECTION SQUARE MATRIX, WITH CONSTANT JACOBIAN S = CONVECT_COEF * TWO_A / 24 & * RESHAPE ( (/ 2, 1, 1, 1, 2, 1, 1, 1, 2 /), (/3, 3/)) ! FACE CONVECTION SOURCE VECTOR C = CONVECT_TEMP * CONVECT_COEF * TWO_A / 6 * (/ 1, 1, 1 /) ELSE IF ( LT_PARM ==1 ) THEN ! edge convection ! GET LENGTH X_I = COORD (1,1) ; X_J = COORD (2,1) Y_I = COORD (1,2) ; Y_J = COORD (2,2) L_IJ = SQRT ( (X_J - X_I)**2 + (Y_J - Y_I)**2 ) ! EDGE CONVECTION SQUARE MATRIX, WITH CONSTANT JACOBIAN S = CONVECT_COEF * THICK * L_IJ / 6 & * RESHAPE ( (/ 2, 1, 1, 2 /), (/ 2, 2 /)) ! EDGE CONVECTION SOURCE VECTOR C = CONVECT_TEMP * CONVECT_COEF * THICK * L_IJ / 2 & * (/ 1.d0, 1.d0 /) ELSE ; S = 0.d0 ; C = 0.d0 END IF ! type of element ! End of application dependent code 204.my_mixed_sq_inc_1 IF ( DEBUG_MIX_SQ ) THEN PRINT *,'Sm '; CALL RPRINT (S,LT_FREE,LT_FREE,1) PRINT *,'Cm '; CALL RPRINT (C, 1,LT_FREE,1) END IF ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE MIXED_SQ_EX_204 SUBROUTINE E_MATRIX_EX_204 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) REAL(DP) :: THICK ! Element thickness ! DEFINE PROPERTIES: 1-K_xx, 2-K_yy, 3-K_xy, 4-Source E (1, 1) = GET_REAL_LP (1) ; E (1, 2) = GET_REAL_LP (3) E (2, 2) = GET_REAL_LP (2) ; E (2, 1) = E (1, 2) ; THICK = 1 IF ( EL_REAL >= 5 ) THICK = GET_REAL_LP (5) E = E * THICK ! for proper flux recovery ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ (1), E (1, 1) END SUBROUTINE E_MATRIX_EX_204 SUBROUTINE POST_PROCESS_MIXED_EX_204 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! MIXED SEGMENT POST-SOLUTION CALCULATIONS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, MIXEDENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_MIXED PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! Define any new array or variable types, then give statements ! Global CONVECT_COEF set by keyword convect_coef is available ! Global CONVECT_TEMP set by keyword convect_temp is available ! H_INTG (LT_N) Integral of interpolation functions, H, available ! Linear triangle face convection heat loss recover REAL(DP) :: X_I, X_J, X_K, Y_I, Y_J, Y_K ! Global coordinates REAL(DP) :: A_I, A_J, A_K, B_I, B_J, B_K ! Standard geometry REAL(DP) :: C_I, C_J, C_K, X_CG, Y_CG, TWO_A ! Standard geometry REAL(DP), SAVE :: Q_LOSS, TOTAL ! Face and total heat loss ! or Linear Line Boundary Face Convection Matrices REAL(DP) :: L_IJ, THICK ! Line length LOGICAL, SAVE :: FIRST = .TRUE. ! printing IF ( FIRST ) THEN ! first call FIRST = .FALSE. ; WRITE (6, 5) ! print headings 5 FORMAT ('*** CONVECTION HEAT LOSS ***', /, & & 'ELEMENT HEAT_LOST') TOTAL = 0.d0 END IF ! first call ! Get convection data from keyword or optional properties THICK = CONVECT_THICK ! default = 1 IF ( MIXED_REAL > 0 ) THEN ! override keyword CONVECT_COEF = GET_REAL_MX (1) ! convection coefficient CONVECT_TEMP = GET_REAL_MX (2) ! convection temperature END IF IF ( LT_PARM == 2 ) THEN ! face convection ! DEFINE NODAL COORDINATES, CCW: I, J, K X_I = COORD (1,1) ; X_J = COORD (2,1) ; X_K = COORD (3,1) Y_I = COORD (1,2) ; Y_J = COORD (2,2) ; Y_K = COORD (3,2) ! GEOMETRIC PARAMETERS: H_I (X,Y) = (A_I + B_I*X + C_I*Y)/TWO_A A_I = X_J * Y_K - X_K * Y_J ; B_I = Y_J - Y_K ; C_I = X_K - X_J A_J = X_K * Y_I - X_I * Y_K ; B_J = Y_K - Y_I ; C_J = X_I - X_K A_K = X_I * Y_J - X_J * Y_I ; B_K = Y_I - Y_J ; C_K = X_J - X_I ! CALCULATE TWICE ELEMENT AREA TWO_A = A_I + A_J + A_K ! = B_J*C_K - B_K*C_J also ! HEAT LOST FROM THIS FACE: Integral over face of h * (T - T_inf) H_INTG (1:3) = TWO_A / 6 ! Integral of H array ELSE IF ( LT_PARM ==1 ) THEN ! edge convection ! GET LENGTH & INTEGRAL X_I = COORD (1,1) ; X_J = COORD (2,1) Y_I = COORD (1,2) ; Y_J = COORD (2,2) L_IJ = SQRT ( (X_J - X_I)**2 + (Y_J - Y_I)**2 ) H_INTG (1:2) = L_IJ * THICK * 0.5d0 ELSE ; H_INTG = 0.d0 END IF ! type of element D (1:LT_N) = D(1:LT_N) - CONVECT_TEMP ! Temp difference at nodes Q_LOSS = CONVECT_COEF * DOT_PRODUCT (H_INTG, D) ! Face loss TOTAL = TOTAL + Q_LOSS ! Running total PRINT '(I6, ES15.5)', IE, Q_LOSS IF ( IE == N_MIXED ) PRINT *, 'TOTAL = ', TOTAL ! *** END POST_PROCESS_MIXED PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_MIXED_EX_204 ! ============= End Files for EXAMPLE number 204 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 205 ============= SUBROUTINE DESCRIBE_EXAMPLE_205 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 205 ***' END SUBROUTINE DESCRIBE_EXAMPLE_205 SUBROUTINE E_MATRIX_EX_205 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) ! 205.my_e_matrix_inc, Torsion of planar shape REAL (DP) :: G_INV G_INV = 1.d0 / GET_REAL_LP (1) ! inverse shear modulus CALL POISSON_ANISOTROPIC_2D_E_MATRIX (G_INV, G_INV, 0.d0, E) ! (K_XX, K_YY, K_XY, E) ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ (1), E (1, 1) STOP 'ERROR: NO SOURCE AT E_MATRIX_EX_205' END SUBROUTINE E_MATRIX_EX_205 SUBROUTINE ELEM_SQ_EX_205 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! TORSION (POISSON EQUATION) OF TWO-DIMENSIONAL SHAPE REAL(DP), PARAMETER :: ZERO = 2 * TINY (1.d0) REAL(DP) :: CONST, DET, SOURCE INTEGER :: IP ! 1/G *(U,xx + U,yy) + Q = 0, Example 205, Q = 2*Angle_of_twist ! Shear modulus = el real property 1 = GET_REAL_LP (1) ! Angle of twist = misc real property 1 = GET_REAL_MISC (1) !--> DEFINE ELEMENT PROPERTIES CALL APPLICATION_E_MATRIX (IE, XYZ, E) ! diagonal 1/G SOURCE = 2.d0 * GET_REAL_MISC (1) ! twice twist ! STORE NUMBER OF POINTS FOR STRESS OR ERROR EST CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !--> NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, (ISOPARAMETRIC) DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT ! FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) CONST = DET * WT(IP) ! EVALUATE GLOBAL DERIVATIVES, B == DGH DGH = MATMUL (AJ_INV, DLH) CALL APPLICATION_B_MATRIX (DGH, XYZ, B) ! for err est ! ELEMENT MATRICES: Stiffness, Source, Result integral S = S + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) C = C + CONST * SOURCE * H ! source H_INTG = H_INTG + H * CONST ! for solution integral !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO !--> SAVE INTEGRAL OF INTERPOLATION FUNCTIONS IF ( N_FILE1 > 0 ) WRITE (N_FILE1) H_INTG ! post_1 keyword ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_205 SUBROUTINE POST_PROCESS_ELEM_EX_205 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_205 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! 205.my_post_el_inc ! .............................................................. ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! Given: INTEGER, INTENT(IN) :: N_FILE1, IE ! REAL(DP), INTENT(IN) :: COORD (LT_N, N_SPACE), D (LT_FREE) ! .............................................................. ! TORSION (POISSON EQUATION) OF TWO-DIMENSIONAL SHAPE ! SHEAR STRESSES AND TORQUE, if keyword post_1 is true (N_FILE1 > 0) LOGICAL, SAVE :: EACH = .false. ! list each torque or total ? CALL LIST_ELEM_TORSION_STRESS (IE) CALL LIST_ELEM_TORQUE_INTEGRAL (N_FILE1, IE, EACH) ! .............................................................. ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! .............................................................. ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER Contains ! the local methods SUBROUTINE LIST_ELEM_TORSION_STRESS (IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST ELEMENT SHEAR STRESS AT QUADRATURE POINTS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! for DP, N_R_B, N_SPACE, E, XYZ Use Elem_Type_Data ! for LT_FREE, LT_N, D, DGH IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! Global Arrays REAL(DP) :: DGH (N_SPACE, LT_FREE), STRESS (N_R_B + 2), & XYZ (N_SPACE), E (N_R_B, N_R_B) INTEGER, SAVE :: TEST_E, TEST_P, J, N_IP ! for max value REAL(DP), SAVE :: DERIV_MAX = -HUGE(1.d0) ! for max value ! VARIABLES: ! D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT ! E = CONSTITUTIVE MATRIX ! DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS ! IE = CURRENT ELEMENT NUMBER ! LT_N = NUMBER OF NODES PER ELEMENT ! LT_FREE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT ! N_ELEMS = TOTAL NUMBER OF ELEMENTS ! N_R_B = NUMBER OF ROWS IN B AND E MATRICES ! N_SPACE = DIMENSION OF SPACE ! STRESS = STRESS OR GRADIENT VECTOR ! XYZ = SPACE COORDINATES AT A POINT !--> PRINT TITLES ON THE FIRST CALL IF ( IE == 1) THEN ; WRITE (N_PRT, 5) 5 FORMAT (/,'*** TORSIONAL SHEAR STRESSES ***',/, & ' ELEMENT, POINT, X Y ', /, & ' ELEMENT, TAU_ZX TAU_ZY TAU', /) ENDIF CALL READ_FLUX_POINT_COUNT (N_IP) ! READ NUMBER OF POINTS DO J = 1, N_IP ! QUADRATURE LOOP CALL READ_FLUX_POINT_DATA (XYZ, E, B) ! RECOVER DATA ! CALCULATE DERIVATIVES, STRESS = E*DGH*D ! STRESS (1:N_R_B) = MATMUL ( E, MATMUL (DGH, D) ) ! shears STRESS (1:N_R_B) = MATMUL (DGH, D) ! shears STRESS (N_R_B+1) = SQRT ( SUM (STRESS(1:N_R_B)**2) ) ! magnitude !--> PRINT COORDINATES AND GRADIENT AT THE POINT WRITE (N_PRT, 20) IE, J, XYZ ! PRINT POINT AND STRESS 20 FORMAT ( I7, I6, 3(1PE13.5)) WRITE (N_PRT, 30) IE, STRESS(2), -STRESS(1), STRESS(3) 30 FORMAT ( I7, 6X, 4(1PE13.5) ) IF ( STRESS (N_R_B+1) > DERIV_MAX ) THEN DERIV_MAX = STRESS (N_R_B+1) ! maximum value TEST_E = IE ; TEST_P = J ! maximum point END IF END DO ! integration !--> ARE GRADIENT CALCULATIONS COMPLETE FOR ALL ELEMENTS IF (IE == N_ELEMS) THEN ! LIST LARGEST SHEAR STRESS WRITE (N_PRT, "('LARGEST SHEAR STRESS = ', 1PE13.5)") DERIV_MAX WRITE (N_PRT, "('ELEM =', I6, ', POINT = ', I2)") TEST_E, TEST_P END IF ! LAST ELEMENT END SUBROUTINE LIST_ELEM_TORSION_STRESS SUBROUTINE LIST_ELEM_TORQUE_INTEGRAL (N_FILE, IE, EACH) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST INTEGRAL OF TORQUE FROM H INTEGRAL, ON N_FILE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! for DP Use Elem_Type_Data ! for LT_FREE, LT_N, D, H_INTG IMPLICIT NONE INTEGER, INTENT(IN) :: N_FILE, IE ! source of data LOGICAL, INTENT(IN) :: EACH ! list each if true REAL(DP), SAVE :: VALUE, TOTAL ! integrals REAL(DP) :: H_INTG (LT_FREE) INTEGER :: EOF ! End_Of_File ! VARIABLES: ! D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT ! EACH = TRUE IF ALL ELEMENTS LISTED, ELSE JUST TOTAL ! H = SOLUTION INTERPOLATION FUNCTIONS ! H_INTG = INTEGRAL OF INTERPOLATION FUNCTIONS ! IE = CURRENT ELEMENT NUMBER ! LT_FREE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT ! N_FILE = UNIT FOR POST SOLUTION MATRICES STORAGE !--> PRINT TITLES ON THE FIRST CALL AND INITIALIZE IF ( IE == 1) THEN ; TOTAL = 0.d0 IF ( EACH ) WRITE (N_PRT, 5) 5 FORMAT (/,'** TORQUE INTEGRAL CONTRIBUTIONS **',/, & 'ELEMENT TORQUE') END IF IF ( IE <= N_ELEMS ) THEN ! ELEMENT RESULTS READ (N_FILE, IOSTAT = EOF) H_INTG ! GET INTEGRAL IF ( EOF /= 0 ) THEN PRINT *, 'LIST_ELEM_TORQUE_INTEGRAL EOF AT ELEMENT ', IE STOP 'ERROR, EOF IN LIST_ELEM_TORQUE_INTEGRAL' END IF ! MISSING DATA !--> CALCULATE ELEMENT CONTRIBUTION, VALUE = H_INTG*D VALUE = DOT_PRODUCT (H_INTG, D) * 2.d0 TOTAL = TOTAL + VALUE IF ( EACH ) WRITE (N_PRT, '(I7, 1PE18.6)') IE, VALUE IF (IE == N_ELEMS) WRITE (N_PRT, & "('TOTAL TORQUE INTEGRAL = ', 1PE16.6, /)") TOTAL END IF END SUBROUTINE LIST_ELEM_TORQUE_INTEGRAL END SUBROUTINE POST_PROCESS_ELEM_EX_205 ! ============= End Files for EXAMPLE number 205 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 206 ============= SUBROUTINE DESCRIBE_EXAMPLE_206 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 206 ***' PRINT *,'ANALYSIS OF A TWO-DIMENSIONAL TRUSS, WITH MEMBER BENDING' PRINT *,'ZIENKIEWICZ, F.E.M. IN STRUCTURAL & CONTINUUM MECH.' PRINT *,'N_G_DOF = 2, NOD_PER_EL = 2, N_SPACE = 2, N_LP_FLO = 7' PRINT *,'ELEMENT REAL PROPERTIES:' PRINT *,'(1) = AREA, (2) = MODULUS OF ELASTICITY,' PRINT *,'(3) = TEMP RISE, (4) = COEF THERMAL EXPANSION,' PRINT *,'(5) = LINE LOAD, (6) = MOMENT OF INERTIA,' PRINT *,'(7) = HALF DEPTH OF BAR' END SUBROUTINE DESCRIBE_EXAMPLE_206 SUBROUTINE ELEM_SQ_EX_206 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Define any new local array or variable types, then statements ! APPLICATION: ANALYSIS OF A TWO-DIMENSIONAL TRUSS, ! WITH MEMBER BENDING ! ZIENKIEWICZ, F.E.M. IN STRUCTURAL & CONTINUUM MECH. ! N_G_DOF = 2, NOD_PER_EL = 2, N_SPACE = 2, N_LP_FLO = 7 ! ELEMENT REAL PROPERTIES: ! (1) = AREA, (2) = MODULUS OF ELASTICITY, ! (3) = TEMP RISE, (4) = COEF THERMAL EXPANSION, ! (5) = LINE LOAD, (6) = MOMENT OF INERTIA, ! (7) = HALF DEPTH OF BAR REAL(DP) :: X_I, X_J, Y_I, Y_J ! coordinates REAL(DP) :: D_X, D_Y, BAR_L ! lengths REAL(DP) :: DELTA_T, ALPHA ! temp rise, expansion REAL(DP) :: AREA ! area REAL(DP) :: DEPTH, INERTIA, PRES ! bending data, line load REAL(DP) :: M_E ! modulus of elasticity REAL(DP) :: C_X, C_Y, C_XX, C_XY, C_YY ! cosines & products REAL(DP) :: F, STIF ! forces, stiffness REAL(DP) :: BEND, THERMAL ! stress recovery ! Get geometry X_I = COORD (1, 1) ; X_J = COORD (2, 1) Y_I = COORD (1, 2) ; Y_J = COORD (2, 2) ! Get properties for this element DELTA_T = 0 ; ALPHA = 0 ; PRES = 0 AREA = GET_REAL_LP (1) M_E = GET_REAL_LP (2) IF ( EL_REAL > 2 ) DELTA_T = GET_REAL_LP (3) IF ( EL_REAL > 3 ) ALPHA = GET_REAL_LP (4) IF ( EL_REAL > 4 ) PRES = GET_REAL_LP (5) !--> FIND BAR LENGTH AND DIRECTION COSINES D_X = X_J - X_I ; D_Y = Y_J - Y_I ! lengths BAR_L = SQRT (D_X * D_X + D_Y * D_Y) ! total length C_X = D_X / BAR_L ; C_Y = D_Y / BAR_L ! cosines !--> FIND 1-D AXIAL STIFFNESS, K=E*A/L STIF = M_E * AREA / BAR_L !--> TRANSFORM TO 2-D STIFFNESS (closed form) C_XX = C_X * C_X ; C_XY = C_X * C_Y ; C_YY = C_Y * C_Y S (1, 1) = STIF * C_XX ; S (2, 1) = STIF * C_XY S (3, 1) = - STIF * C_XX ; S (4, 1) = - STIF * C_XY S (1, 2) = STIF * C_XY ; S (2, 2) = STIF * C_YY S (3, 2) = - STIF * C_XY ; S (4, 2) = - STIF * C_YY S (1, 3) = - STIF * C_XX ; S (2, 3) = - STIF * C_XY S (3, 3) = STIF * C_XX ; S (4, 3) = STIF * C_XY S (1, 4) = - STIF * C_XY ; S (2, 4) = - STIF * C_YY S (3, 4) = STIF * C_XY ; S (4, 4) = STIF * C_YY ! Form mechanical strain-displacement matrix to post-process B (1, 1) = - C_X / BAR_L ; B (1, 2) = - C_Y / BAR_L B (1, 3) = C_X / BAR_L ; B (1, 4) = C_Y / BAR_L ! Form any local loads C = 0.d0 ; THERMAL = 0.d0 ; BEND = 0.d0 ! initialize !--> INITIAL THERMAL STRAIN EFFECTS IF ( DELTA_T /= 0.d0 .AND. EL_REAL > 5 ) THEN THERMAL = ALPHA * DELTA_T ! thermal strain F = M_E * THERMAL * AREA ! thermal force C (1) = - C_X * F ; C (2) = - C_Y * F ! components C (3) = C_X * F ; C (4) = C_Y * F ! components END IF ! thermal !--> LINE LOAD EFFECTS (POSITIVE TO RIGHT, FROM NODE I TO J ) IF ( PRES /= 0.d0 ) THEN INERTIA = GET_REAL_LP (6) ! data DEPTH = GET_REAL_LP (7) ! data IF ( INERTIA <= 0.d0 ) INERTIA = 1.d0 ! default IF ( DEPTH <= 0.d0 ) DEPTH = 1.d0 ! default BEND = PRES * DEPTH * BAR_L **2 / (8 * INERTIA) ! stress F = PRES * BAR_L / 2 ! pressure resultant C (1) = C (1) + C_Y * F ! component C (2) = C (2) - C_X * F ! component C (3) = C (3) + C_Y * F ! component C (4) = C (4) - C_X * F ! component END IF ! bending ! Save for stress post-processing IF ( N_FILE1 > 0 ) WRITE (N_FILE1) M_E, B, BEND, THERMAL ! End of application dependent code ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_206 SUBROUTINE POST_PROCESS_ELEM_EX_206 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_206 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! Define any new array or variable types, then give statements ! ! APPLICATION: ANALYSIS OF A TWO-DIMENSIONAL TRUSS, ! WITH MEMBER BENDING ! ZIENKIEWICZ, F.E.M. IN STRUCTURAL & CONTINUUM MECH. ! N_G_DOF = 2, NOD_PER_EL = 2, N_SPACE = 2, N_LP_FLO = 7 ! ELEMENT REAL PROPERTIES: ! (1) = AREA, (2) = MODULUS OF ELASTICITY, ! (3) = TEMP RISE, (4) = COEF THERMAL EXPANSION, ! (5) = LINE LOAD, (6) = MOMENT OF INERTIA, ! (7) = HALF DEPTH OF BAR ! STRESS = M_E (MECHANICAL STRAIN) +- BEND - M_E (THERMAL STRAIN) REAL(DP) :: BEND, MIDDLE (2), THERMAL ! stress recovery REAL(DP) :: M_E ! modulus of elasticity INTEGER, SAVE :: CALLS = 0 IF ( CALLS == 0 ) THEN ! first call CALLS = 1 ; WRITE (6, 10) ! print headings 10 FORMAT (' E L E M E N T S T R E S S E S', /, & & ' ELEMENT MID SECTION STRESS AT:', /, & & ' NUMBER RIGHT LEFT', /) END IF ! first call !--> READ STRESS DATA OFF N_FILE1 READ (N_FILE1) M_E, B, BEND, THERMAL !---> CALCULATE MECHANICAL STRESS, STRESS = E * B * D STRESS (1) = M_E * DOT_PRODUCT ( B(1, :), D ) ! ADD THERMAL AND PRESSURE EFFECTS (CENTER, TOP & BOTTOM) MIDDLE (1) = STRESS (1) + BEND - M_E * THERMAL MIDDLE (2) = STRESS (1) - BEND - M_E * THERMAL WRITE (6, 11) IE, MIDDLE (1:2) ; 11 FORMAT (I5, 1X, 2E20.7) ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_206 ! ============= End Files for EXAMPLE number 206 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 207 ============= SUBROUTINE DESCRIBE_EXAMPLE_207 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 207 ***' PRINT *, "TWO-DIMENSIONAL TRUSS, DIRECT ENERGY METHOD" PRINT *, "N_G_DOF = 2, NOD_PER_EL = 2, N_SPACE = 2, N_LP_FLO = 7" PRINT *, "ELEMENT REAL PROPERTIES: " PRINT *, "(1) = AREA, (2) = MODULUS OF ELASTICITY," PRINT *, "(3) = TEMP RISE, (4) = COEF THERMAL EXPANSION," PRINT *, "(5) = WEIGHT DENSITY" PRINT *, " " PRINT *, "DATA SET 1" PRINT *, " 2 4 5 Meek's Example 7.2 truss" PRINT *, " *--(10)-*--(11)-* E = 30,000 ksi, A = 1 in^2" PRINT *, " |\(4) /|\(7) /| Two 10 inch bays" PRINT *, " | \ / | \ / | Max vertical deflection @ 3" PRINT *, " (3) X (6) X (9) is -4.4013E-03 inches" PRINT *, " | / \ | / \ |" PRINT *, " |/(5) \|/(8) \| Reactions are 5K each at 1, 6" PRINT *, " 1 #--(1)--*--(2)--o 6" PRINT *, " Pin 3| Roller" PRINT *, " v P=10K" PRINT *, "DATA SET 2" PRINT *, " Logan Example 15.1, Fixed bar with temperature rise" PRINT *, " 1 2 3" PRINT *, " *--(1)--*--(2)--* E = 30,000 ksi, A = 4 in^2" PRINT *, " L = 4 ft = 48 inches, alpha = 7e-6, rise = 50 F" PRINT *, " Reactions are 42,000 lb, stress = 10,500 psi" PRINT *, " End points 1 & 3 fixed, solution is null" PRINT *, "DATA SET 3" PRINT *, " Logan Example 15.3, 2-D Truss with temperature rise" PRINT *, " occuring in bar (1) only" PRINT *, " 1 o Y_Roller E = 30,000 ksi, A = 2 in^2" PRINT *, " | \ 8 ft high, 6 ft wide (96 by 72)" PRINT *, " (1) (2) alpha = 7e-6, rise = 75 F" PRINT *, " | \ Y_1 = 0.0333 inch" PRINT *, " 2 * * 3 Stress: -5,333, + 6,666 psi" PRINT *, " Pin Pin" PRINT *, "DATA SET 4 " PRINT *, " Logan Example 3.9, 2-D Truss with inclined support" PRINT *, " 2,X_Roller 3,Roller_at_45" PRINT *, " P->o--(2)--o E = 210 GPA, A_1 = A_2 = 6e-4 m^2" PRINT *, " | / A_3 = 8.485 m^2, 1 m high, 1 m wide " PRINT *, " (1) (3) P = 1e3 kN, alpha = 0, rise = 0 " PRINT *, " | / DX_2 = 11.9e-3 m. F_1_Y = -500 kN" PRINT *, " 1 */ Note: (1) is a zero force member" PRINT *, " Pin " PRINT *, "DATA SET 5" PRINT *, "Elastic linear bar patch test" END SUBROUTINE DESCRIBE_EXAMPLE_207 SUBROUTINE ELEM_SQ_EX_207 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! A TWO-DIMENSIONAL TRUSS BY DIRECT ENERGY APPROACH ! ELEMENT REAL PROPERTIES: (1) = AREA, (2) = ELASTIC MODULUS ! (3) = TEMP RISE, (4) = COEFF EXPANSION, (5) = WEIGHT DENSITY REAL(DP) :: X_I, X_J, Y_I, Y_J ! coordinates REAL(DP) :: D_X, D_Y, BAR_L ! lengths REAL(DP) :: DELTA_T, ALPHA ! temp rise, expansion REAL(DP) :: AREA, GAMMA ! area, wt. density REAL(DP) :: M_E, THERMAL ! modulus, thermal strain REAL(DP) :: C_X, C_Y, PRES ! cosines, pressure ! Get geometry X_I = COORD (1, 1) ; X_J = COORD (2, 1) Y_I = COORD (1, 2) ; Y_J = COORD (2, 2) ! Get properties for this element AREA = GET_REAL_LP (1) ; M_E = GET_REAL_LP (2) DELTA_T = 0 ; ALPHA = 0 ; PRES = 0 IF ( EL_REAL > 2 ) DELTA_T = GET_REAL_LP (3) IF ( EL_REAL > 3 ) ALPHA = GET_REAL_LP (4) IF ( EL_REAL > 4 ) PRES = GET_REAL_LP (5) ! Find bar length and direction cosines D_X = X_J - X_I ; D_Y = Y_J - Y_I ! lengths BAR_L = SQRT (D_X * D_X + D_Y * D_Y) ! total length C_X = D_X / BAR_L ; C_Y = D_Y / BAR_L ! cosines ! Form global strain-displacement matrix B (1, :) = (/ - C_X, - C_Y, C_X, C_Y /) / BAR_L ! Form global stiffness, S = B' EAL B S = M_E * AREA * BAR_L * MATMUL ( TRANSPOSE (B), B ) ! Initial (thermal) strain loading THERMAL = ALPHA * DELTA_T ! strain C = B (1, :) * M_E * THERMAL * AREA * BAR_L ! force ! Weight load, in negative Y-direction (wt density * volume) C = C + (/ 0.d0, -0.5d0, 0.d0, -0.5d0 /) & ! components * GAMMA * AREA * BAR_L ! total weight ! Save for stress post-processing (set post_1 in keywords) IF ( N_FILE1 > 0 ) WRITE (N_FILE1) M_E, B, THERMAL ! End of application dependent code ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_207 SUBROUTINE POST_PROCESS_ELEM_EX_207 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_207 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! A TWO-DIMENSIONAL TRUSS BY DIRECT ENERGY APPROACH ! ELEMENT REAL PROPERTIES: (1) = AREA, (2) = ELASTIC MODULUS ! (3) = TEMP RISE, (4) = COEFF EXPANSION, (5) = WEIGHT DENSITY ! STRESS = M_E * (MECHANICAL STRAIN - INITIAL STRAIN) REAL(DP) :: THERMAL ! initial strain REAL(DP) :: M_E ! modulus of elasticity LOGICAL, SAVE :: FIRST = .TRUE. ! printing IF ( FIRST ) THEN ! first call FIRST = .FALSE. ; WRITE (6, 5) ! print headings 5 FORMAT (' E L E M E N T S T R E S S E S', /, & & ' ELEMENT STRESS MECH. STRAIN THERMAL STRAIN') END IF ! first call !--> Read stress strain data from N_FILE1 (set by post_1) READ (N_FILE1) M_E, B, STRAIN_0 (1) ! THERMAL = STRAIN_0 !--> Calculate mechanical strain, STRAIN = B * D STRAIN (1) = DOT_PRODUCT ( B(1, :), D ) !--> Generalized Hooke's Law STRESS (1) = M_E * (STRAIN (1) - STRAIN_0 (1)) WRITE (6, 1) IE, STRESS (1), STRAIN (1), STRAIN_0 (1) 1 FORMAT (I5, 3ES15.5) ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_207 ! ============= End Files for EXAMPLE number 207 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 208 ============= SUBROUTINE DESCRIBE_EXAMPLE_208 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 208 ***' PRINT *, 'Axisymmetric Heat Transfer' PRINT *, 'EXAMPLE=208, DATA_SET=01, EXACT_CASE=22' PRINT *, 'Equation: Axisymmetric anisotropic Poisson' PRINT *, 'Remarks: A Sphere with R=1 and temperature specified as' PRINT *, 'T(R=1,a) = Cos^2 a_, for angle a_ from R_axis' PRINT *, 'T(x,y) = r^2*(cos^2 a_ -1/3) + 1/3, r^2 = x^2 + y^2' PRINT *, 'Note EXAMPLE=208 is EXAMPLE=209 with keyword axisymmetric' AXISYMMETRIC = .true. ; EXAMPLE = 209 END SUBROUTINE DESCRIBE_EXAMPLE_208 ! ============= End Files for EXAMPLE number 208 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 209 ============= SUBROUTINE DESCRIBE_EXAMPLE_209 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 209 ***' PRINT *,'ANISOTROPIC POISSON EQUATION IN 1-, 2-, or 3-D' PRINT *,' VIA NUMERICALLY INTEGRATED ELEMENTS' PRINT *,' Standard Element Properties assumed: ' PRINT *,' 1-D problem, K_xx, Q, Thickness' PRINT *,' 2-D problem, K_xx, K_yy, K_xy, Q, Thickness' PRINT *,' 3-D problem, K_xx, K_yy, K_zz, K_xy, K_xz, K_yz, Q' PRINT *,' Convection Element Properties assumed:' PRINT *,' Point: h, T_inf, Area' PRINT *,' Line: h, T_inf, Thickness' PRINT *,' Face: h, T_inf' END SUBROUTINE DESCRIBE_EXAMPLE_209 SUBROUTINE ELEM_SQ_EX_209 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! ANISOTROPIC POISSON EQUATION IN 1-, 2-, or 3-DIMENSIONS ! VIA NUMERICALLY INTEGRATED ELEMENTS ! (K_ij * U,i),j + Q = 0; 1 <= (i,j) <= N_SPACE REAL(DP) :: CONST, DET, THICK ! integration REAL(DP) :: SOURCE ! data INTEGER :: IP ! counter ! Properties assumed, (order in GET_REAL_LP (n)): ! 1-D problem, K_xx, Q, Thickness ! 2-D problem, K_xx, K_yy, K_xy, Q, Thickness ! 3-D problem, K_xx, K_yy, K_zz, K_xy, K_xz, K_yz, Q CALL POISSON_ANISOTROPIC_E_MATRIX (E) ! for 1-, 2-, or 3-D SOURCE = 0 ; IF ( SCALAR_SOURCE /= 0.d0 ) SOURCE = SCALAR_SOURCE THICK = 1 ; IF ( AREA_THICK /= 1.d0 ) THICK = AREA_THICK IF ( EL_REAL > 0 ) THEN ! Get local element constant values, SELECT CASE (N_SPACE) ! for source or thickness CASE (1) ; IF ( EL_REAL > 1 ) SOURCE = GET_REAL_LP (2) IF ( EL_REAL > 2 ) THICK = GET_REAL_LP (3) CASE (2) ; IF ( EL_REAL > 3 ) SOURCE = GET_REAL_LP (4) IF ( EL_REAL > 4 ) THICK = GET_REAL_LP (5) CASE (3) ; IF ( EL_REAL > 6 ) SOURCE = GET_REAL_LP (7) END SELECT END IF ! element data provided CALL STORE_FLUX_POINT_COUNT ! Save LT_QP, for post-process DO IP = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) ! inverse IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IP) * THICK DGH = MATMUL (AJ_INV, DLH) ! Physical gradient B = COPY_DGH_INTO_B_MATRIX (DGH) ! B = DGH ! VARIABLE VOLUMETRIC SOURCE, via keyword use_exact_source ! Defaults to file my_exact_source_inc if no exact_case key IF ( USE_EXACT_SOURCE ) CALL & ! analytic Q SELECT_EXACT_SOURCE (XYZ, SOURCE) ! via exact_case key C = C + CONST * SOURCE * H ! source resultant ! CONDUCTION SQUARE MATRIX (THICKNESS IN E) S = S + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) IF ( DEBUG_EL_SQ ) THEN PRINT *, 'THICK ', THICK PRINT *, 'S std' ; CALL RPRINT (S, LT_FREE, LT_FREE, 1) PRINT *, 'C std' ; CALL RPRINT (C, 1, LT_FREE, 1) END IF !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, (E * THICK), B) END DO ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_209 SUBROUTINE MIXED_SQ_EX_209 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE MIXED_BC SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** MIXED_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Mixed or Robin boundary condition, Standard form: ! K_n * U,n + ROBIN_1_SEG * U + ROBIN_2_SEG = 0 ! Set in keywords robin_square and robin_column ! H_INTG (LT_N) Integral of H available to store INTEGER :: IQ ! Integration loop REAL(DP) :: CONST, DET, THICK ! face area IF ( N_FILE2 > 0 ) H_INTG = 0 ! via post_mixed, for post_process ! GET ROBIN TERMS, IF GLOBAL CONSTANTS ! Set in keywords robin_square and robin_column, or via ! convect_coef, convect_temp for convection special case THICK = 1.d0 ! if an edge IF ( CONVECTION ) THEN ! constant convection all segments ROBIN_1_SEG = CONVECT_COEF ROBIN_2_SEG = -CONVECT_COEF * CONVECT_TEMP !b !b ROBIN_2_SEG = CONVECT_COEF * CONVECT_TEMP !XXX check sign IF ( LT_PARM < 2 ) THICK = CONVECT_THICK ! point or line END IF ! Convection ! GET ROBIN TERMS, IF LOCAL SEGMENT CONSTANTS IF ( MIXED_REAL > 0 ) THEN ! are local data IF ( CONVECT_VARY ) THEN ! data are coeff, temperature, thick ROBIN_1_SEG = GET_REAL_MX (1) ! convection coeff ROBIN_2_SEG = 0.d0 ! default temperature effect IF ( MIXED_REAL > 1 ) ROBIN_2_SEG = -ROBIN_1_SEG & * GET_REAL_MX (2) ! coeff*temp !b IF ( MIXED_REAL > 2 ) THICK = GET_REAL_MX (3) IF ( MIXED_REAL > 2 .AND. LT_PARM < 2 ) THICK = GET_REAL_MX (3) ELSE ! a non-convection Robin condition ROBIN_1_SEG = GET_REAL_MX (1) ; ROBIN_2_SEG = 0.d0 IF ( MIXED_REAL > 1 ) ROBIN_2_SEG = GET_REAL_MX (2) !b IF ( MIXED_REAL > 2 ) THICK = GET_REAL_MX (3) IF ( MIXED_REAL > 2 .AND. LT_PARM < 2 ) THICK = GET_REAL_MX (3) END IF ! convection or general Robin data !b ROBIN_1_SEG = GET_REAL_MX (1) !b IF ( MIXED_REAL > 1 ) ROBIN_2_SEG = GET_REAL_MX (2) !b IF ( MIXED_REAL > 2 ) THICK = GET_REAL_MX (3) END IF ! local data IF ( LT_N > 1 ) THEN ! Not a single point, must integrate DO IQ = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IQ) ! BOUNDARY INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, (ISOPARAMETRIC) DLH = GET_DLH_AT_QP (IQ) ! FIND LOCAL DERIVATIVES ! FORM DETERMINATE OF GENERALIZED JACOBIAN, Fig 5.4.2 DET = PARM_GEOM_METRIC (DLH, COORD) ! dX / dr IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IQ) * THICK IF ( N_FILE2 > 0 ) H_INTG = H_INTG + H * DET * WT(IQ) ! GET VARIABLE ROBIN DATA, via use_exact_robin keyword IF ( USE_EXACT_ROBIN ) CALL SELECT_EXACT_ROBIN_DATA & (XYZ, ROBIN_1_SEG, ROBIN_2_SEG) S = S + ROBIN_1_SEG * CONST * OUTER_PRODUCT (H, H) ! Sq C = C - ROBIN_2_SEG * CONST * H ! Source !b C = C + ROBIN_2_SEG * CONST * H ! Source END DO ELSE ! This is a point value, maybe analytic expression IF ( AXISYMMETRIC ) THICK = TWO_PI * COORD (1, 1) IF ( USE_EXACT_ROBIN ) CALL SELECT_EXACT_ROBIN_DATA & (COORD (1, :), ROBIN_1_SEG, ROBIN_2_SEG) S (1, 1) = ROBIN_1_SEG * THICK C (1) = -ROBIN_2_SEG * THICK !b C (1) = ROBIN_2_SEG * THICK IF ( N_FILE2 > 0 ) H_INTG = THICK ! actually area at pt, input END IF ! boundary segment type IF ( N_FILE2 > 0 ) WRITE (N_FILE2) H_INTG ! via post_mixed IF ( DEBUG_MIX_SQ ) THEN PRINT *, 'Smixed ' ; CALL RPRINT (S, LT_FREE, LT_FREE, 1) PRINT *, 'Cmixed ' ; CALL RPRINT (C, 1, LT_FREE, 1) PRINT *, 'Hntgrl ' ; CALL RPRINT ( H_INTG, 1, LT_FREE, 1) END IF ! End mixed condition BC 209.my_mixed_sq_inc ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE MIXED_SQ_EX_209 SUBROUTINE SEG_COL_EX_209 (E, H_INTG, PRT_L_PT, PRT_MAT,& L_PT_PROP, IE, FLUX) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE FLUX SEGMENT COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Geometric_Properties Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! OPTIONAL FLUX VALUES IF BOUNDARY SEGMENT ELEMENT REAL(DP), INTENT(IN) :: FLUX (L_B_N, N_G_FLUX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & XYZ (N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** SEG_COL_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! Given normal flux on an element face or edge: ! Standard form: -K_n * U,n = Q_NORMAL_SEG (in System_Constants) INTEGER :: IQ ! loops REAL(DP) :: CONST, DET, THICK ! flux area ! Get normal flux from keyword, or segment property IF ( .NOT. FLUX_NORMAL ) THEN ! no normal_flux key for Q_NORMAL_SEG Q_NORMAL_SEG = 0.d0 ; THICK = 1.d0 IF ( SEG_REAL > 0 ) Q_NORMAL_SEG = GET_REAL_SP (1) IF ( SEG_REAL > 1 ) THICK = GET_REAL_SP (2) ELSE ! Global constant for Q_NORMAL_SEG & FLUX_THICK THICK = FLUX_THICK END IF IF ( LT_N > 1 ) THEN ! Not a point value DO IQ = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IQ) ! BOUNDARY INTERPOLATION FUNCTIONS ! FIND GLOBAL COORD, XYZ = H*COORD (ISOPARAMETRIC) XYZ = MATMUL (H, COORD) ! FIND LOCAL DERIVATIVES DLH = GET_DLH_AT_QP (IQ) ! FORM DETERMINATE OF GENERALIZED JACOBIAN DET = PARM_GEOM_METRIC (DLH, COORD) ! dX / dr IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IQ) * THICK ! GET NORMAL FLUX COMPONENT IF ( USE_EXACT_FLUX ) CALL SELECT_EXACT_NORMAL_FLUX & (XYZ, Q_NORMAL_SEG) ! via keyword use_exact_flux C = C + Q_NORMAL_SEG * CONST * H ! Source vector END DO ELSE ! This is a point value IF ( USE_EXACT_FLUX ) CALL SELECT_EXACT_NORMAL_FLUX & (COORD (1, :), Q_NORMAL_SEG) ! via use_exact_flux C (1) = Q_NORMAL_SEG END IF ! boundary segment type ! End application dependent flux 209.my_seg_col_inc_2 ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, FLUX END SUBROUTINE SEG_COL_EX_209 SUBROUTINE POST_PROCESS_MIXED_EX_209 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! MIXED SEGMENT POST-SOLUTION CALCULATIONS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, MIXEDENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_MIXED PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! Define any new array or variable types, then give statements ! Global CONVECT_COEF set by keyword convect_coeff is available ! Global CONVECT_TEMP set by keyword convect_temp is available ! H_INTG (LT_N) Integral of interpolation functions, H, available ! Linear triangle face convection heat loss recover REAL(DP) :: X_I, X_J, X_K, Y_I, Y_J, Y_K ! Global coordinates REAL(DP) :: A_I, A_J, A_K, B_I, B_J, B_K ! Standard geometry REAL(DP) :: C_I, C_J, C_K, X_CG, Y_CG, TWO_A ! Standard geometry REAL(DP), SAVE :: Q_LOSS, TOTAL = 0.d0 ! Surface & total loss REAL(DP) :: THICK ! line width LOGICAL, SAVE :: FIRST = .TRUE. ! printing IF ( FIRST ) THEN ! first call FIRST = .FALSE. ; WRITE (6, 5) ! print headings 5 FORMAT ('*** CONVECTION HEAT LOSS ***', /, & & 'ELEMENT HEAT_LOST') TOTAL = 0.d0 END IF ! first call !b IF ( N_FILE2 > 0 .and. LT_QP > 1 ) THEN ! H already integrated IF ( N_FILE2 > 0 ) THEN ! H already integrated !b READ (N_FILE2) H_INTG ! via post_mixed ELSE ! compute it here, for T3 only IF ( LT_N /= 3 ) STOP '209.POST_PROCESS_MIXED EXPECTED T3 ELEMENTS' ! DEFINE NODAL COORDINATES, CCW: I, J, K X_I = COORD (1,1) ; X_J = COORD (2,1) ; X_K = COORD (3,1) Y_I = COORD (1,2) ; Y_J = COORD (2,2) ; Y_K = COORD (3,2) ! GEOMETRIC PARAMETERS: H_I (X,Y) = (A_I + B_I*X + C_I*Y)/TWO_A A_I = X_J * Y_K - X_K * Y_J ; B_I = Y_J - Y_K ; C_I = X_K - X_J A_J = X_K * Y_I - X_I * Y_K ; B_J = Y_K - Y_I ; C_J = X_I - X_K A_K = X_I * Y_J - X_J * Y_I ; B_K = Y_I - Y_J ; C_K = X_J - X_I ! CALCULATE TWICE ELEMENT AREA TWO_A = A_I + A_J + A_K ! = B_J*C_K - B_K*C_J also H_INTG (1:3) = TWO_A / 6 ! Integral of H array END IF ! H_INTG ! Get convection coff and temp, maybe thickness ! GET ROBIN TERMS, IF GLOBAL CONSTANTS ! Set in keywords robin_square and robin_column, or via ! convect_coef, convect_temp for convection special case THICK = 1.d0 ! if an edge IF ( CONVECTION ) THEN ! constant convection all segments ! Then CONVECT_COEF, CONVECT_TEMP, CONVECT_THICK global IF ( LT_PARM < 2 ) THICK = CONVECT_THICK ! point or line END IF ! Convection ! GET ROBIN TERMS, IF LOCAL SEGMENT CONSTANTS IF ( MIXED_REAL > 0 ) THEN ! are local data IF ( CONVECT_VARY ) THEN ! data are coeff, temperature, thick CONVECT_COEF = GET_REAL_MX (1) ! convection coeff CONVECT_TEMP = 0.d0 ! default temperature effect IF ( MIXED_REAL > 1 ) CONVECT_TEMP = GET_REAL_MX (2) ! temp IF (MIXED_REAL > 2 .AND. LT_PARM < 2) THICK = GET_REAL_MX (3) ELSE ! a non-convection Robin condition PRINT *,'WARNING: NEED KEY convect_coef OR convect_vary ' N_WARN = N_WARN + 1 STOP 'POST_PROCESS_MIXED 208,209, or 302 ERROR 2' END IF END IF ! local data IF ( DEBUG_MIX_SQ .OR. DEBUG_POST_EL ) THEN PRINT *, 'H Integral for element ' , THIS_EL CALL RPRINT ( H_INTG, 1, LT_FREE, 1) END IF ! HEAT LOST FROM THIS FACE: Integral over face of h * (T - T_inf) D (1:LT_N) = D(1:LT_N) - CONVECT_TEMP ! Temp difference at nodes Q_LOSS = CONVECT_COEF * DOT_PRODUCT (H_INTG, D) ! Face loss IF ( LT_PARM < 2 ) Q_LOSS = Q_LOSS * THICK ! line or point TOTAL = TOTAL + Q_LOSS ! Running total PRINT '(I6, ES15.5)', IE, Q_LOSS IF ( IE == N_MIXED ) PRINT *, 'TOTAL = ', TOTAL ! *** END POST_PROCESS_MIXED PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_MIXED_EX_209 !============= End Files for EXAMPLE number 209 =============== ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 210 ============= SUBROUTINE DESCRIBE_EXAMPLE_210 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 210 ***' PRINT *, 'Example 210, CST plane stress analysis' PRINT *, 'Exact integrals saved as one point quadrature' PRINT *, 'Element real properties: ' PRINT *, "1-Elastic modulus, 2-Poisson's ratio" PRINT *, 'If el_real >= 3, thickness is 3rd ' PRINT *, 'If el_real >= 4, body force components are 4th & 5th ' PRINT *, 'If el_real >= 6, yield stress is 6th ' PRINT *, 'Keyword area_thick also available as global data' PRINT *, ' ' PRINT *, 'DATA SET 1' PRINT *, 'Two element test with point load' PRINT *, 'DATA SET 2' PRINT *, 'Four element constant x-body force, linear x-stress' PRINT *, 'quadratic x-displacements, crude mesh' END SUBROUTINE DESCRIBE_EXAMPLE_210 SUBROUTINE ELEM_SQ_EX_210 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Note: BODY (N_SPACE) is available through the interface ! Linear Triangle, T3, Plane stress only ! STRESS AND STRAIN COMPONENT ORDER: XX, YY, XY, SO N_R_B = 3 ! Element real properties: 1-Elastic modulus, 2-Poisson's ratio ! If el_real >= 3, thickness is 3rd property ! If el_real >= 4, body force components are 4th & 5th property ! If el_real >= 6, yield stress is 6th property REAL(DP) :: X_I, X_J, X_K, Y_I, Y_J, Y_K ! Global coordinates REAL(DP) :: A_I, A_J, A_K, B_I, B_J, B_K ! Standard geometry REAL(DP) :: C_I, C_J, C_K, X_CG, Y_CG, TWO_A ! Standard geometry REAL(DP), SAVE :: THICK = 1.d0 ! Element thickness ! DEFINE NODAL COORDINATES, CCW: I, J, K X_I = COORD (1,1) ; X_J = COORD (2,1) ; X_K = COORD (3,1) Y_I = COORD (1,2) ; Y_J = COORD (2,2) ; Y_K = COORD (3,2) ! DEFINE CENTROID COORDINATES (QUADRATURE POINT) X_CG = (X_I + X_J + X_K)/3.d0 ; Y_CG = (Y_I + Y_J + Y_K)/3.d0 ! GEOMETRIC PARAMETERS: H_I (X,Y) = (A_I + B_I*X + C_I*Y)/TWO_A A_I = X_J * Y_K - X_K * Y_J ; B_I = Y_J - Y_K ; C_I = X_K - X_J A_J = X_K * Y_I - X_I * Y_K ; B_J = Y_K - Y_I ; C_J = X_I - X_K A_K = X_I * Y_J - X_J * Y_I ; B_K = Y_I - Y_J ; C_K = X_J - X_I ! CALCULATE TWICE ELEMENT AREA TWO_A = A_I + A_J + A_K ! = B_J*C_K - B_K*C_J also ! DEFINE 3 BY 6 STRAIN-DISPLACEMENT MATRIX, B B (1, 1:6) = (/ B_I, 0.d0, B_J, 0.d0, B_K, 0.d0 /) / TWO_A B (2, 1:6) = (/ 0.d0, C_I, 0.d0, C_J, 0.d0, C_K /) / TWO_A B (3, 1:6) = (/ C_I, B_I, C_J, B_J, C_K, B_K /) / TWO_A CALL E_PLANE_STRESS (E) ! THE CONSTITUTIVE MATRIX IF ( GLOBAL_PROPERTY ) THEN ! one or more data are global IF ( AREA_THICK /= 1.d0 ) THICK = AREA_THICK ELSE ! local non-homogeneous data IF ( EL_REAL >= 3 ) THICK = GET_REAL_LP (3) END IF ! global TWO_A = TWO_A * THICK ! true volume ! STIFFNESS MATRIX, WITH CONSTANT JACOBIAN S = MATMUL ( TRANSPOSE (B), MATMUL (E, B) ) * TWO_A * 0.5d0 ! BODY FORCE PER UNIT VOLUME, AS GLOBAL CONSTANTS IF ( .NOT. HAS_BODY_FORCE ) THEN ! Check element values in array IF ( EL_REAL >= 5 ) THEN BODY_FORCE (1) = GET_REAL_LP (4) BODY_FORCE (2) = GET_REAL_LP (5) ELSE ; BODY_FORCE = 0.d0 END IF END IF ! or set up properties for body force C (1:5:2) = BODY_FORCE (1) * TWO_A / 6.d0 ! X component C (2:6:2) = BODY_FORCE (2) * TWO_A / 6.d0 ! Y component ! SAVE ONE POINT RULE TO AVERAGING, OR ERROR ESTIMATOR LT_QP = 1 ; CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !b CALL STORE_FLUX_POINT_DATA ( (/ X_CG, Y_CG /), E*THICK, B ) CALL STORE_FLUX_POINT_DATA ( (/ X_CG, Y_CG /), E, B ) if ( DEBUG_EL_SQ ) then print *,'THIS_EL, Thick, Vol ', THIS_EL, THICK, TWO_A print *,'E matrix:' ; call rprint (E, N_R_B, N_R_B, 1) print *,'S matrix:' ; call rprint (S, LT_FREE, LT_FREE, 1) print *,'C matrix:' ; call rprint (C, 1, LT_FREE, 1) end if ! End of application dependent code ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_210 SUBROUTINE POST_PROCESS_ELEM_EX_210 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_210 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! PLANE_STRESS ANALYSIS ! STRESS AND STRAIN COMPONENT ORDER: XX, YY, XY, SO N_R_B = 3 ! PROPERTIES: 1-YOUNG'S MODULUS, 2-POISSON'S RATIO, AND ! 3-YIELD STRESS, IF PRESENT INTEGER :: J, N_IP ! LOOPS REAL(DP), SAVE :: YIELD ! FAILURE DATA IF ( IE == 1 ) THEN ! PRINT TITLES & INITIALIZE STRAIN = 0.d0 ; STRAIN_0 = 0.d0 ! INITIALIZE ALL OF "STRAIN" IF ( EL_REAL > 3 ) THEN ! INITIALIZE YIELD STRESS YIELD = GET_REAL_LP (6) ELSE ; YIELD = HUGE (1.d0) ; END IF ! YIELD DATA WRITE (6, 50) ; 50 FORMAT ( /, & '*** STRESSES AT INTEGRATION POINTS ***', /, & ' COORDINATES STRESSES', /, & 'POINT X Y XX YY', /, & 'POINT XY EFFECTIVE') END IF ! NEW HEADINGS WRITE (6, * ) ' ELEMENT NUMBER ', IE CALL READ_FLUX_POINT_COUNT (N_IP) ! NUMBER OF QUADRATURE POINTS DO J = 1, N_IP ! AT QUADRATURE POINTS CALL READ_FLUX_POINT_DATA (XYZ, E, B) ! PT, PROP, STRAIN_DISP ! MECHANICAL STRAINS & STRESSES (less initial & effective) STRAIN (1:N_R_B) = MATMUL (B, D) ! STRAINS AT THE POINT STRESS (1:N_R_B) = MATMUL (E, STRAIN(1:N_R_B)) ! STRESSES ! VON_MISES FAILURE CRITERION (EFFECTIVE STRESS, ADD TO END) STRESS (4) = SQRT ( (STRESS (1) - STRESS (2) ) **2 & + (STRESS (2)) **2 + (STRESS (1)) **2 & + 6.d0 * STRESS (3) **2 ) * 0.7071068d0 IF ( STRESS (4) >= YIELD ) PRINT *, & 'WARNING: FAILURE CRITERION EXCEEDED IN ELEMENT =', IE ! LIST STRESSES AND FAILURE CRITERION AT POINT WRITE (6, 52) J, XYZ (1:2), STRESS (1:2) WRITE (6, 51) J, STRESS (3:4) 52 FORMAT ( I3, 2(1PE11.3), 5(1PE14.5) ) 51 FORMAT ( I3, 22X, 5(1PE14.5) ) END DO ! AT QUADRATURE POINTS ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_210 ! ============= End Files for EXAMPLE number 210 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 211 ============= SUBROUTINE DESCRIBE_EXAMPLE_211 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 211 ***' PRINT *, 'Advection-Diffusion Equations: 1-D, 2-D, 3-D, Axisymmetric' PRINT *, 'u * Del P - Del ( E Del P) + r P - Q = 0' PRINT *, 'VIA NUMERICALLY INTEGRATED ELEMENTS, E = diffusity * I' PRINT *, 'MISCELLANEOUS REAL PROPERTIES: (1) = diffusity ' PRINT *, '(2) = SOURCE, Q, (optional, defaults to 0)' PRINT *, '(3) = r, (optional, defaults to 0)' PRINT *, '(4) = THICKNESS (optional, defaults to 1 or radius)' PRINT *, 'NOTE: u is defined via subroutine VELOCITY_AT_POINT' END SUBROUTINE DESCRIBE_EXAMPLE_211 SUBROUTINE E_MATRIX_EX_211 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) ! 211.my_e_matrix_inc, used by ! FUNCTION GET_APPLICATION_E_MATRIX (IE, XYZ) RESULT (E) REAL(DP), SAVE :: VISCOSITY LOGICAL, SAVE :: FIRST_CALL = .TRUE. IF ( FIRST_CALL ) THEN ! one time calculations FIRST_CALL = .FALSE. VISCOSITY = 1.d0 ! initialize IF ( REALS > 0 ) VISCOSITY = GET_REAL_MISC (1) ! diffusity END IF CALL REAL_IDENTITY (N_R_B, E) ; E = E * VISCOSITY ! End 211.my_e_matrix_inc ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ (1), E (1, 1) END SUBROUTINE E_MATRIX_EX_211 SUBROUTINE ELEM_SQ_EX_211 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Advection-Diffusion Equations: 1-D, 2-D, 3-D, Axisymmetric ! u * Del P - Del ( E Del P) + r P - Q = 0 ! VIA NUMERICALLY INTEGRATED ELEMENTS ! MISCELLANEOUS REAL PROPERTIES: (1) = diffusity ! (2) = SOURCE, Q, (optional, defaults to 0) ! (3) = r, (optional, defaults to 0) ! (4) = THICKNESS (optional, defaults to 1 or radius) ! NOTE: u is defined via subroutine VELOCITY_AT_POINT REAL(DP) :: CONST, DET, DET_WT, THICK ! integration REAL(DP) :: SOURCE, RATE ! data: Q & r INTEGER :: IP ! counter ! Required upwind items REAL(DP) :: CENTER (N_SPACE) ! average of nodes REAL(DP) :: U (N_SPACE) ! Velocity vector REAL(DP) :: UNIT_V (N_SPACE), SPEED ! unit vector, speed REAL(DP) :: U_DGH (LT_N) ! streamline gradient REAL(DP) :: D2GH (N_2_DER, LT_N) ! 2nd deriv of H REAL(DP) :: E_UP, E_CROSS ! Diffusion up & cross REAL(DP) :: VISCOSITY ! in E REAL(DP) :: TAU ! stabilize term ! Stabilization matrix notations REAL(DP) :: S_M (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_C (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_K (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_K_BAR (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_R_BAR (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_UP (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: C_UP (LT_FREE) ! SUPG column matrix ! Optional geometric upwind items REAL(DP) :: RADIAL (LT_N, N_SPACE) ! relative positions REAL(DP) :: DOWN (LT_N) ! downwind wrt center REAL(DP) :: DOWN_NODAL (LT_N) ! downwind total REAL(DP) :: GEOM_H, VOL_H ! element DW lengths REAL(DP) :: GEOM_TAU, VOL_TAU ! element Tau values REAL(DP) :: PECLET, ALPHA ! Re Peclet number LOGICAL :: IS_DOWNWIND (LT_N) ! true if downwind node ! Optional norm based upwind items REAL(DP) :: ONE_PT (LT_PARM), ONE_WT ! 1 pt rule REAL(DP) :: UGN_TAU ! ugn REAL(DP) :: S1_TAU, NORM_C, NORM_K_BAR ! s1_norm ! Initialize element S_M = 0 ; S_C = 0 ; S_K = 0 !--> DEFINE ELEMENT PROPERTIES RATE = 0 ; SOURCE = 0 ; THICK = 1 ; VISCOSITY = 1 ! initialize IF ( REALS > 0 ) VISCOSITY = GET_REAL_MISC (1) ! constant diffusity IF ( REALS > 1 ) SOURCE = GET_REAL_MISC (2) ! constant Q IF ( REALS > 2 ) RATE = GET_REAL_MISC (3) ! constant r IF ( REALS > 3 ) THICK = GET_REAL_MISC (4) ! constant thickness IF ( VISCOSITY <= 0.d0 ) STOP 'ERROR: IMPOSSIBLE VISCOSITY <= 0' CENTER = SUM ( COORD, DIM=1 ) / LT_N ! center point CALL APPLICATION_E_MATRIX (IE, CENTER, E) ! constitutive law IF ( SUPG ) THEN ! Streamline Upwind Petrov-Galerkin additions ! INITIALIZE STABILIZATION ARRAYS S_UP = 0.d0 ; C_UP = 0.d0 ; H_INTG = 0.d0 S_K_BAR = 0.d0 ; S_R_BAR = 0.d0 ! GET CENTER VELOCITY AND DIFFUSION CALL VELOCITY_AT_POINT (CENTER, U, UNIT_V, SPEED) ! velocity ! GET DIFFUSION ALONG STREAMLINE CALL DIFFUSION_UPWIND (E, UNIT_V, E_UP, E_CROSS) ! transform IF ( E_UP <= 0.d0 ) STOP 'ELEM_SQ_MATRIX: IMPOSSIBLE E_UP <= 0.d0' IF ( TAU_GEOM .OR. TAU_VOL .OR. TAU_SHOW ) THEN CALL GET_RADIALS_FROM_CENTER (CENTER, RADIAL) CALL GET_DOWNWIND_LOGIC (RADIAL, UNIT_V, DOWN, IS_DOWNWIND) CALL GET_MAX_DOWNWIND_DIST (DOWN, DOWN_NODAL) END IF IF ( TAU_GEOM .OR. TAU_SHOW ) THEN GEOM_H = ABS (MINVAL (DOWN)) + MAXVAL (DOWN) PECLET = 0.5d0 * SPEED * GEOM_H / E_UP CALL PECLET_OPTIMAL_RULE (PECLET, ALPHA) GEOM_TAU = 0.5d0 * GEOM_H * ALPHA / SPEED END IF ! Tau_geom IF ( TAU_UGN .OR. TAU_SHOW ) THEN CALL GET_ONE_PT_RULE (ONE_PT, ONE_WT) ! local point CALL SCALAR_DERIVS (ONE_PT, DLH) ! deriv of H AJ = MATMUL (DLH, COORD) ! Jacobian, J CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) ! Inverse of J DGH = MATMUL (AJ_INV, DLH) ! Del H U_DGH = MATMUL (U, DGH) ! u dot Del H UGN_TAU = 1.d0 / SUM ( ABS (U_DGH) ) ! Tau ugn value END IF ! Tau_ugn END IF ! Initialize upwinding ! STORE NUMBER OF POINTS FOR FLUX CALCULATIONS CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !--> NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT ! FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IP) * THICK ! local measure H_INTG = H_INTG + H * CONST ! H integral ! EVALUATE GLOBAL DERIVATIVES, DGH == B DGH = MATMUL (AJ_INV, DLH) ! Physical gradient H ! Note: D2GH assumed zero here ! 2nd Derivs H B = DGH ! copy DGH into B ! VARIABLE VOLUMETRIC SOURCE, via keyword use_exact_source ! Defaults to file my_exact_source_inc if no exact_case key IF ( USE_EXACT_SOURCE ) CALL & ! analytic Q SELECT_EXACT_SOURCE (XYZ, SOURCE) ! via exact_case key ! GALERKIN SOURCE TERM C = C + CONST * SOURCE * H ! source resultant ! DIFFUSION SQUARE MATRIX S_K = S_K + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) ! ADD RATE SQUARE MATRIX from -r*U S_M = S_M + RATE * OUTER_PRODUCT (H, H) * CONST ! IGNORE SQUARE MATRIX FROM 2nd DERIVATIVES, INITIALLY ! SET STREAMLINE DIRECTION (AND DEFAULT IF SPEED = 0) CALL VELOCITY_AT_POINT (XYZ, U, UNIT_V, SPEED) IF ( SPEED <= 0.d0 ) THEN SPEED = EPSILON (1.d0) ! Avoid / 0 U (1) = EPSILON (1.d0) ! Avoid / 0 END IF ! No speed ! ADVECTION SQUARE MATRIX -V*Grad_U U_DGH = MATMUL (U, DGH) ! vel dot grad H S_C = S_C + OUTER_PRODUCT (H, U_DGH) * CONST ! no upwind IF ( SUPG ) THEN ! UPWIND AT QP ! GET DIFFUSION ALONG STREAMLINE CALL DIFFUSION_UPWIND (E, UNIT_V, E_UP, E_CROSS) IF ( E_UP < 0.d0 ) STOP 'ELEM_SQ_MATRIX: IMPOSSIBLE E_UP < 0.d0' ! FORM STABILIZATION ARRAYS (LESS Tau SCALE) C_UP = C_UP + SOURCE * U_DGH * CONST S_K_BAR = S_K_BAR + OUTER_PRODUCT (U_DGH, U_DGH) * CONST ! - 2nd deriv, & varaiable E, now neglected S_R_BAR = S_R_BAR + OUTER_PRODUCT (U_DGH, H) * RATE * CONST END IF ! VARIABLE UPWIND !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, (E * THICK), B) END DO ! for integration S = S_K + S_M + S_C ! if no upwinding IF ( TAU_VOL .OR. TAU_SHOW ) THEN ! integral average downwind dist VOL_H = DOT_PRODUCT (H_INTG, DOWN_NODAL) & / SUM (H_INTG) / LT_N ! integral average PECLET = 0.5d0 * SPEED * VOL_H / E_UP CALL PECLET_OPTIMAL_RULE (PECLET, ALPHA) VOL_TAU = 0.5d0 * VOL_H * ALPHA / SPEED END IF ! Tau geom IF ( SUPG ) THEN ! STABILIZE SOLUTION, DEFAULT TO S1 NORM_C = SQRT ( SUM ( S_C **2 ) ) ! 2 norm NORM_K_BAR = SQRT ( SUM ( S_K_BAR **2 ) ) ! 2 norm S1_TAU = NORM_C / NORM_K_BAR ! norm method IF ( TAU_GEOM ) THEN ! keywords supg and tau_geom IF ( THIS_EL == 1 ) PRINT *, 'NOTE: used tau_geom' TAU = GEOM_TAU ELSEIF ( TAU_UGN ) THEN ! keywords supg and tau_ugn IF ( THIS_EL == 1 ) PRINT *, 'NOTE: used tau_ugn' TAU = UGN_TAU ELSEIF ( TAU_VOL ) THEN ! keywords supg and tau_vol IF ( THIS_EL == 1 ) PRINT *, 'NOTE: used tau_vol' TAU = VOL_TAU ELSEIF ( TAU_S1 ) THEN ! keywords supg and tau_s1 IF ( THIS_EL == 1 ) PRINT *, 'NOTE: used tau_s1' TAU = S1_TAU ELSE ! keyword supg only IF ( THIS_EL == 1 ) PRINT *, 'NOTE: defaulted to tau_s1' TAU = S1_TAU END IF ! user selection ! FORM SUPG ADDITIONS C = C + C_UP * TAU S_UP = (S_K_BAR + S_R_BAR) * TAU S = S + S_UP END IF ! SUPG ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_211 ! ============= End Files for EXAMPLE number 211 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 212 ============= SUBROUTINE DESCRIBE_EXAMPLE_212 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 212 ***' PRINT *, 'Donald_s Put Equations: 1-D, 2-D, 3-D' PRINT *, 'u * Del P - E(XYZ) * Del (Del P) + r P - Q = 0' PRINT *, 'VIA NUMERICALLY INTEGRATED ELEMENTS' PRINT *, 'Misc reals are: 1-Sig_1 2-Sig_2= 3-rho= 4-r= 5-Q' PRINT *, 'E_11 = Sig_1^2 X^2 /2, E_22 = Sig_2^2 Y^2 /2 ' PRINT *, 'E_12 =rho Sig_1 Sig_2 X Y /2 = E_21 ; U = -r XYZ(1:2)' END SUBROUTINE DESCRIBE_EXAMPLE_212 SUBROUTINE E_MATRIX_EX_212 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) REAL(DP) :: E_11, E_12, E_22 REAL(DP), PARAMETER :: XYZ_1 = 25d0, XYZ_2 = 50.d0 ! XXX ! Donald's Put Equations: 1-D, 2-D, 3-D ! u * Del P - E * Del (Del P) + r P - Q = 0 ! Misc reals are: 1-Sig_1 2-Sig_2= 3-rho= 4-r= 5-Q SELECT CASE ( N_SPACE ) CASE (1) ; E(1,1) = 0.5d0 * (GET_REAL_MISC (1)) **2 * XYZ (1) **2 CASE (2) IF ( USER_LOGIC ) THEN ! use center value only E_11 = 0.5d0 * (GET_REAL_MISC (1)) **2 * XYZ_1 **2 E_22 = 0.5d0 * (GET_REAL_MISC (2)) **2 * XYZ_2 **2 E_12 = GET_REAL_MISC (3) * 0.5d0 & * GET_REAL_MISC (1) * XYZ_1 & * GET_REAL_MISC (2) * XYZ_2 ELSE ! use current point value E_11 = 0.5d0 * (GET_REAL_MISC (1)) **2 * XYZ (1) **2 E_22 = 0.5d0 * (GET_REAL_MISC (2)) **2 * XYZ (2) **2 E_12 = GET_REAL_MISC (3) * 0.5d0 & * GET_REAL_MISC (1) * XYZ (1) & * GET_REAL_MISC (2) * XYZ (2) END IF ! E selection CALL POISSON_ANISOTROPIC_2D_E_MATRIX (E_11, E_22, E_12, E) ! (K_XX, K_YY, K_XY, E) CASE DEFAULT ; STOP 'INVALID SPACE, E_MATRIX_EX_212' END SELECT ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE END SUBROUTINE E_MATRIX_EX_212 SUBROUTINE ELEM_SQ_EX_212 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Donald's Put Equations: 1-D, 2-D, 3-D, Example number 212 ! u * Del P - E(XYZ) * Del (Del P) + r P - Q = 0 ! VIA NUMERICALLY INTEGRATED ELEMENTS ! Misc reals are: 1-Sig_1 2-Sig_2= 3-rho= 4-r= 5-Q ! E_11 = 0.5d0 * (GET_REAL_MISC (1)) **2 * XYZ (1) **2 ! E_22 = 0.5d0 * (GET_REAL_MISC (2)) **2 * XYZ (2) **2 ! E_12 = GET_REAL_MISC (3) * 0.5d0 & ! * GET_REAL_MISC (1) * XYZ (1) & ! * GET_REAL_MISC (2) * XYZ (2) ; U = -r XYZ(1:2) REAL(DP), PARAMETER :: NIL = EPSILON (1.d0) REAL(DP) :: CONST, DET, DET_WT ! integration INTEGER :: IP, I_ERROR ! counter ! Varaible E items REAL(DP), SAVE :: Sig_1, Sig_2, rho, rate, source ! Global data REAL(DP) :: GRAD_DOT_E (N_SPACE) ! Del dot E REAL(DP) :: NORM_E, SPEED_CG, RE_ELEM ! array norms ! Required upwind items REAL(DP) :: CENTER (N_SPACE) ! average of nodes REAL(DP) :: U (N_SPACE) ! Velocity vector REAL(DP) :: UNIT_V (N_SPACE), SPEED ! unit vector, speed REAL(DP) :: U_DGH (LT_N) ! streamline gradient REAL(DP) :: E_UP, E_CROSS ! Diffusion up & cross REAL(DP) :: TAU ! stabilize term LOGICAL :: MOVING ! SPEED /= 0 ! Stabilization matrix notations REAL(DP) :: S_M (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_C (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_K (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_K_BAR (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_R_BAR (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_UP (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: C_UP (LT_FREE) ! SUPG column matrix REAL(DP) :: D2H_L (N_2_DER, LT_N) ! 2ND deriv local REAL(DP) :: D2GH (N_2_DER, LT_N) ! 2nd deriv of H REAL(DP) :: P_AJ (N_2_DER, N_2_DER) ! AJ PRODUCTS REAL(DP) :: P_AJ_INV (N_2_DER, N_2_DER) ! PRODUCTS INVERSE REAL(DP) :: E_VECTOR (N_2_DER) ! work vector REAL(DP) :: E_D2GH (LT_N) ! work vector ! Optional geometric upwind items REAL(DP) :: RADIAL (LT_N, N_SPACE) ! relative positions REAL(DP) :: DOWN (LT_N) ! downwind wrt center REAL(DP) :: DOWN_NODAL (LT_N) ! downwind total REAL(DP) :: GEOM_H , VOL_H ! element DW length !b REAL(DP) :: GEOM_TAU, VOL_TAU ! element lengths REAL(DP) :: ALPHA, COTH ! Re Peclet number REAL(DP) :: PECLET, PEC_TAU ! Re Peclet number REAL(DP), SAVE :: Max_Pe ! debug system Pe LOGICAL :: IS_DOWNWIND (LT_N) ! true if downwind node ! Optional norm based upwind items REAL(DP) :: ONE_PT (LT_PARM), ONE_WT ! 1 pt rule REAL(DP) :: UGN_TAU ! ugn REAL(DP) :: S1_TAU, S3_TAU ! s1_norm, s3_norm REAL(DP) :: NORM_C, NORM_K_BAR ! array norms LOGICAL, SAVE :: FIRST_CALL = .TRUE. IF ( FIRST_CALL ) THEN ! one time calculations FIRST_CALL = .FALSE. !--> DEFINE GLOBAL PROPERTIES ! Misc reals are:1-Sig_1 2-Sig_2= 3-rho= 4-r= 5-Q RATE = 0 ; SOURCE = 0 ! initialize Sig_1 = 1 ; Sig_2 = 1 ; rho = 0 IF ( REALS > 0 ) Sig_1 = GET_REAL_MISC (1) IF ( REALS > 1 ) Sig_2 = GET_REAL_MISC (2) IF ( REALS > 2 ) rho = GET_REAL_MISC (3) IF ( REALS > 3 ) RATE = GET_REAL_MISC (4) IF ( REALS > 4 ) SOURCE= GET_REAL_MISC (5) END IF ! FIRST CALL ! Initialize element S_M = 0 ; S_C = 0 ; S_K = 0 TAU = 0 ; GEOM_TAU = 0 ; UGN_TAU = 0 ; S1_TAU = 0 !b Max_Pe = 0 ; PECLET = 0 ; ALPHA = 1 !b CENTER = SUM ( COORD, DIM=1 ) / LT_N ! center point CALL APPLICATION_E_MATRIX (IE, CENTER, E) ! constitutive IF ( SUPG ) THEN ! Streamline Upwind Petrov-Galerkin additions ! INITIALIZE STABILIZATION ARRAYS S_UP = 0.d0 ; C_UP = 0.d0 ; H_INTG = 0.d0 S_K_BAR = 0.d0 ; S_R_BAR = 0.d0 !b E_INTEGRAL = 0.d0 ; VOL_EL = 0.d0 ! GET CENTER VELOCITY AND DIFFUSION !b CALL VELOCITY_AT_POINT (CENTER, U, UNIT_V, SPEED) U = - RATE * CENTER ! Donald CALL UNIT_VECTOR_FORM (U, UNIT_V, SPEED) IF ( SPEED <= NIL ) THEN MOVING = .FALSE. SPEED = NIL ! Avoid / 0 and 0 / 0 U = NIL ! for N_SPACE components UNIT_V = 1.d0 / SQRT (DBLE(N_SPACE)) ! for N_SPACE components END IF ! almost zero convection NORM_E = SQRT ( SUM ( E **2 ) ) / SIZE ( E, 1) ! E norm SPEED_CG = SPEED ! save velocity to plot N_FILE5.DAT IF ( N_FILE5 > 0 ) WRITE (N_FILE5, '( (10(1PE13.5)) )') CENTER, U ! GET DIFFUSION ALONG STREAMLINE CALL DIFFUSION_LOCAL (E, UNIT_V, E_UP) ! // to streamline IF ( E_UP <= 0.d0 ) STOP 'ELEM_SQ_MATRIX: INVALID E_UP <= 0' IF ( TAU_GEOM .OR. TAU_VOL .OR. TAU_SHOW ) THEN !b CALL GET_RADIALS_FROM_CENTER (CENTER, RADIAL) CALL GET_DOWNWIND_LOGIC (RADIAL, UNIT_V, DOWN, IS_DOWNWIND) CALL GET_MAX_DOWNWIND_DIST (DOWN, DOWN_NODAL) END IF IF ( TAU_GEOM .OR. TAU_SHOW ) THEN !b GEOM_H = ABS (MINVAL (DOWN)) + MAXVAL (DOWN) !b PECLET = 0.5d0 * SPEED * GEOM_H / E_UP !b CALL PECLET_OPTIMAL_RULE (PECLET, ALPHA) !b GEOM_TAU = 0.5d0 * GEOM_H * ALPHA / SPEED !b END IF ! Tau_geom IF ( TAU_UGN .OR. TAU_SHOW ) THEN CALL GET_ONE_PT_RULE (ONE_PT, ONE_WT) ! local point CALL SCALAR_DERIVS (ONE_PT, DLH) ! deriv of H AJ = MATMUL (DLH, COORD) ! Jacobian, J CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) ! Inverse of J DGH = MATMUL (AJ_INV, DLH) ! Del H U_DGH = MATMUL (U, DGH) ! u dot Del H UGN_TAU = 1.d0 / SUM ( ABS (U_DGH) ) ! Tau ugn value END IF ! Tau_ugn END IF ! Initialize upwinding ! STORE NUMBER OF POINTS FOR FLUX CALCULATIONS CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !--> NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT ! FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) CONST = DET * WT(IP) ! local measure H_INTG = H_INTG + H * CONST ! H integral ! EVALUATE GLOBAL DERIVATIVES, DGH == B DGH = MATMUL (AJ_INV, DLH) ! Physical gradient B = COPY_DGH_INTO_B_MATRIX (DGH) ! B = DGH ! VARIABLE VOLUMETRIC SOURCE, via keyword use_exact_source ! Defaults to file my_exact_source_inc if no exact_case key IF ( USE_EXACT_SOURCE ) CALL & ! analytic Q SELECT_EXACT_SOURCE (XYZ, SOURCE) ! via exact_case key ! GALERKIN SOURCE TERM C = C + CONST * SOURCE * H ! source resultant ! VARIABLE E MATRIX IF ( VARY_E ) E = GET_APPLICATION_E_MATRIX (IE, XYZ) ! DIFFUSION SQUARE MATRIX S_K = S_K + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) ! ADD RATE SQUARE MATRIX from -r*P S_M = S_M + RATE * OUTER_PRODUCT (H, H) * CONST ! SET STREAMLINE DIRECTION CALL VELOCITY_AT_POINT (XYZ, U, UNIT_V, SPEED) U = - RATE * XYZ ! Donald CALL UNIT_VECTOR_FORM (U, UNIT_V, SPEED) ! ADVECTION SQUARE MATRIX -u*Grad_P U_DGH = MATMUL (U, DGH) ! vel dot grad H S_C = S_C + OUTER_PRODUCT (H, U_DGH)*CONST ! no upwind ! GRADIENT OF E CONTRIBUTIONS IF ( VARY_E ) THEN GRAD_DOT_E (1) = Sig_1*XYZ(1)*(Sig_1 + rho*Sig_2 * 0.5d0) !b GRAD_DOT_E (2) = Sig_2*XYZ(2)*(Sig_2 + rho*Sig_1 * 0.5d0) !b S_K = S_K + OUTER_PRODUCT (H, MATMUL (GRAD_DOT_E, B))*CONST END IF ! E varies in space IF ( SUPG ) THEN ! UPWIND AT QP ! GET DIFFUSION ALONG STREAMLINE !b CALL DIFFUSION_LOCAL (E, UNIT_V, E_UP) !b IF ( E_UP < 0.d0 ) STOP 'ELEM_SQ_MATRIX: INVALID E_UP < 0' ! FORM STABILIZATION ARRAYS (LESS Tau SCALE) C_UP = C_UP + SOURCE * U_DGH * CONST S_R_BAR = S_R_BAR + OUTER_PRODUCT (U_DGH, H) * RATE * CONST S_K_BAR = S_K_BAR + OUTER_PRODUCT (U_DGH, U_DGH) * CONST ! - E * 2nd deriv IF ( GET_2ND_DERIV ) THEN ! add 2nd derivative terms ! EXACT 3: U,xx U,yx=U,xy U,yy ! FE 4: U,xx U,yx U,xy U,yy ! Get second derivatives, un-smoothed CALL JACOBIAN_PRODUCTS (AJ, P_AJ) ! ALWAYS NEEDED ! NOTE: D2GH = P_AJ_INV (D2LH - HESSIAN * DGH) ! HESSIAN = D2LH * COORD CALL INV_SMALL_MAT (N_2_DER, P_AJ, P_AJ_INV, I_ERROR) IF ( I_ERROR > 0 ) THEN PRINT *, 'ERROR: SUPG w 2ND DERIV, NO PRODUCT INVERSE' STOP 'ERROR: SUPG w 2ND DERIV, NO PRODUCT INVERSE' END IF ! INVERSION ERROR CALL SCALAR_2ND_DERIVS (PT(:, IP), D2LH) ! some elem only IF ( CONSTANT_J ) THEN ! AJ constant so Hessian == 0 D2GH = MATMUL (P_AJ_INV, D2LH) ELSE ! use full Hessian matrix D2GH = MATMUL (P_AJ_INV, (D2LH & - MATMUL (MATMUL (D2LH, COORD), DGH))) END IF ! ZERO HESSIAN ! complete matrix products, H' (E x D2GH) if ( N_SPACE /= 2 ) STOP '2ND Deriv only for 2D in el_sq' E_VECTOR = (/ E(1,1), E(1,2), E(2,2) /) !B 2d only, make mask E_D2GH (:) = DOT_PRODUCT (E_VECTOR, & PACK (D2GH (1:N_2_DER, :), .TRUE.) ) !b PACK XXX Rank 1 of array operand has extent 4 instead of 3. Fatal S_K_BAR = S_K_BAR + OUTER_PRODUCT (H, E_D2GH) * CONST END IF ! 2nd deriv END IF ! VARIABLE UPWIND !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO ! for integration S = S_K + S_M + S_C ! if no upwinding IF ( DEBUG_EL_SQ .AND. THIS_EL < 3 ) THEN print *,'S_K '; call rprint (S_K , LT_FREE, LT_FREE,1) print *,'S_M '; call rprint (S_M , LT_FREE, LT_FREE,1) print *,'S_C '; call rprint (S_C , LT_FREE, LT_FREE,1) print *,'C '; call rprint (C , 1, LT_FREE,1) IF ( SUPG ) THEN print *,'S_K_BAR '; call rprint (S_K_BAR, LT_FREE, LT_FREE,1) print *,'S_R_BAR '; call rprint (S_R_BAR, LT_FREE, LT_FREE,1) print *,'C_UP '; call rprint (C_UP , 1, LT_FREE,1) END IF END IF ! debug IF ( TAU_VOL .OR. TAU_SHOW ) THEN ! integral average DW dist VOL_H = DOT_PRODUCT (H_INTG, DOWN_NODAL) & !b / SUM (H_INTG) ! integral average !b PECLET = 0.5d0 * SPEED * VOL_H / E_UP !b CALL PECLET_OPTIMAL_RULE (PECLET, ALPHA) !b VOL_TAU = 0.5d0 * VOL_H * ALPHA / SPEED !b END IF ! Tau geom IF ( SUPG ) THEN ! STABILIZE SOLUTION IF ( TAU_S1 .OR. TAU_SHOW ) THEN NORM_C = SQRT ( SUM ( S_C **2 ) ) / SIZE ( S_C, 1) NORM_K_BAR = SQRT ( SUM ( S_K_BAR **2 ) ) / SIZE ( S_K_BAR, 1) S1_TAU = NORM_C / NORM_K_BAR RE_ELEM = SPEED_CG **2 * S1_TAU / NORM_E S3_TAU = RE_ELEM * S1_TAU END IF IF ( PECLET > Max_Pe ) Max_Pe = PECLET IF (IE == N_ELEMS) PRINT *,'Maximum element Pe = ', Max_Pe IF ( TAU_GEOM ) THEN TAU = GEOM_TAU ELSEIF ( TAU_UGN ) THEN TAU = UGN_TAU ELSEIF ( TAU_VOL ) THEN TAU = VOL_TAU ELSEIF ( TAU_S1 ) THEN TAU = 1.d0 / SQRT ( 1 / S1_TAU **2 + 1 / S3_TAU **2 ) ELSE TAU = S1_TAU !b BOX_TAU END IF ! user selection IF ( TAU_SHOW .AND. THIS_EL == 1 ) THEN print *,'GEOM_T ', GEOM_TAU print *,'S1_T ', S1_TAU print *,'UGN_T VOL_T ', UGN_TAU, VOL_TAU print *,'TAU ', TAU END IF !if ( THIS_EL <= 3 ) THEN ! print *, 'TAU_S1, TAU ', TAU_S1, TAU ! print *, 'THIS_EL, S1_TAU, NORM_E, SPEED_CG, RE_ELEM, S3_TAU' ! print *, THIS_EL, S1_TAU, NORM_E, SPEED_CG, RE_ELEM, S3_TAU !end if C = C + C_UP * TAU S_UP = (S_K_BAR + S_R_BAR) * TAU S = S + S_UP END IF ! SUPG IF ( DEBUG_EL_SQ .AND. THIS_EL < 3 ) THEN IF ( SUPG ) THEN print *,'S_UP '; call rprint (S_UP , LT_FREE, LT_FREE,1) END IF print *,'S '; call rprint (S , LT_FREE, LT_FREE,1) print *,'C '; call rprint (C , 1, LT_FREE,1) END IF ! debug ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_212 ! ============= End Files for EXAMPLE number 212 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 213 ============= SUBROUTINE DESCRIBE_EXAMPLE_213 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 213 ***' PRINT *, 'Donald_s Black-Sholes: 2-D (E_P_S_V_Risk) Example 213' PRINT *, 'u(x) * Del P - Del (E(x) Del P) + r P - Q = 0' PRINT *, 'VIA NUMERICALLY INTEGRATED ELEMENTS' PRINT *, 'x=XYZ, 1-S price, 2-V Volatility' PRINT *, 'Misc reals are: 1-Sigma 2-Kappa 3-Rho ' PRINT *, '4-r 5-Theta 6-Lamda 7-Q' PRINT *, 'E_11 = 0.5d0 * XYZ (2) * XYZ (1) **2 ' PRINT *, 'E_22 = 0.5d0 * (Sigma) **2 * XYZ (2) ' PRINT *, 'E_12 = 0.5d0 * Sigma * XYZ (1) * Kappa * XYZ (2) = E_21' PRINT *, 'u_1 = -(r - XYZ(2) - Rho * Sigma / 2) * XYZ(1)' PRINT *, 'u_2 = -Kappa*(Theta - XYZ(2)) + Sigma * Sigma / 2 ' PRINT *, '+ (Lamda + Rho * Sigma / 2) * XYZ(2) ' PRINT *, 'Strike, S_max V_max, if exact_reals 1 or 3 and use_exact_bc' END SUBROUTINE DESCRIBE_EXAMPLE_213 SUBROUTINE E_MATRIX_EX_213 (IE, XYZ, E) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GET APPLICATION DEPENDENT E MATRIX FOR CONSTITUTIVE LAW ! (USED IF SUPERCONVERGENT PATCH GRADIENTS ARE ACTIVE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Sys_Properties_Data IMPLICIT NONE INTEGER, INTENT (IN) :: IE REAL (DP), INTENT(IN) :: XYZ (N_SPACE) REAL (DP), INTENT(OUT) :: E (N_R_B, N_R_B) ! Donald's Black-Sholes: 2-D (E_P_S_V_Risk) ! u(x) * Del P - Del (E(x) Del P) + r P - Q = 0 ! VIA NUMERICALLY INTEGRATED ELEMENTS REAL(DP), SAVE :: Sigma, Kappa, Rho, rate ! Global data REAL(DP), SAVE :: Theta, Lamda, source ! Global data ! x=XYZ, 1-S price, 2-V Volatility ! Misc reals are: 1-Sigma 2-Kappa 3-Rho 4-r 5-Theta 6-Lamda 7-Q ! E_11 = 0.5d0 * XYZ (2) * XYZ (1) **2 ! E_22 = 0.5d0 * (REAL (1)) **2 * XYZ (2) ! E_12 = 0.5d0 * REAL (1) * XYZ (1) * REAL (2) * XYZ (2) = E_21 IF ( THIS_EL == 1 ) THEN ! Get global data ! Misc reals are: 1-Sigma 2-Kappa 3-Rho 4-r 5-Theta 6-Lamda 7-Q Sigma = 0.9d0 ; Rho = 0.1d0 ! Clarke-Parrott IF ( REALS > 0 ) Sigma = GET_REAL_MISC (1) IF ( REALS > 2 ) Rho = GET_REAL_MISC (3) END IF ! first el E (1, 1) = 0.5d0 * XYZ (2) * XYZ (1) **2 E (2, 1) = 0.5d0 * Sigma * XYZ (1) * Rho * XYZ (2) E (1, 2) = E (2, 1) E (2, 2) = 0.5d0 * Sigma **2 * XYZ (2) ! end application E matrix ! suppress compiler warnings (touch is never true) IF ( TOUCH ) PRINT *, IE, XYZ (1), E (1, 1) END SUBROUTINE E_MATRIX_EX_213 SUBROUTINE ELEM_SQ_EX_213 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Donald's Black-Sholes: 2-D (E_P_S_V_Risk) Example 213 ! u(x) * Del P - Del (E(x) Del P) + r P - Q = 0 ! VIA NUMERICALLY INTEGRATED ELEMENTS ! x=XYZ, 1-S price, 2-V Volatility ! Misc reals are: 1-Sigma 2-Kappa 3-Rho 4-r 5-Theta 6-Lamda 7-Q ! E_11 = 0.5d0 * XYZ (2) * XYZ (1) **2 ! E_22 = 0.5d0 * (REAL (1)) **2 * XYZ (2) ! E_12 = 0.5d0 * REAL (1) * XYZ (1) * REAL (2) * XYZ (2) = E_21 ! u_1 = -(r - XYZ(2) - Rho * Sigma / 2) * XYZ(1) ! u_2 = -Kappa*(Theta - XYZ(2)) + Sigma * Sigma / 2 ! + (Lamda + Rho * Sigma / 2) * XYZ(2) REAL(DP), PARAMETER :: NIL = EPSILON (1.d0) REAL(DP) :: CONST, DET, DET_WT ! integration INTEGER :: IP, I_ERROR ! counter ! Variable E, u items REAL(DP), SAVE :: Sigma, Kappa, Rho, rate ! Global data REAL(DP), SAVE :: Theta, Lamda, source ! Global data REAL(DP) :: NORM_E, SPEED_CG, RE_ELEM ! array norms ! Required upwind items REAL(DP) :: CENTER (N_SPACE) ! average of nodes REAL(DP) :: U (N_SPACE) ! Velocity vector REAL(DP) :: UNIT_V (N_SPACE), SPEED ! unit vector, speed REAL(DP) :: U_DGH (LT_N) ! streamline gradient REAL(DP) :: E_UP, E_CROSS ! Diffusion up & cross REAL(DP) :: TAU ! stabilize term LOGICAL :: MOVING ! SPEED /= 0 ! Stabilization matrix notations REAL(DP) :: S_M (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_C (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_K (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_K_BAR (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_R_BAR (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: S_UP (LT_FREE, LT_FREE) ! SUPG sq matrix REAL(DP) :: C_UP (LT_FREE) ! SUPG column matrix REAL(DP) :: D2H_L (N_2_DER, LT_N) ! 2ND deriv local REAL(DP) :: D2GH (N_2_DER, LT_N) ! 2nd deriv of H REAL(DP) :: P_AJ (N_2_DER, N_2_DER) ! AJ PRODUCTS REAL(DP) :: P_AJ_INV (N_2_DER, N_2_DER) ! PRODUCTS INVERSE REAL(DP) :: E_VECTOR (N_2_DER) ! work vector REAL(DP) :: E_D2GH (LT_N) ! work vector ! Optional geometric upwind items REAL(DP) :: RADIAL (LT_N, N_SPACE) ! relative positions REAL(DP) :: DOWN (LT_N) ! downwind wrt center REAL(DP) :: DOWN_NODAL (LT_N) ! downwind total REAL(DP) :: GEOM_H , VOL_H ! element DW length !b REAL(DP) :: GEOM_TAU, VOL_TAU ! element lengths REAL(DP) :: ALPHA, COTH ! Re Peclet number REAL(DP) :: PECLET, PEC_TAU ! Re Peclet number REAL(DP), SAVE :: Max_Pe ! debug system Pe LOGICAL :: IS_DOWNWIND (LT_N) ! true if downwind node ! Optional norm based upwind items REAL(DP) :: ONE_PT (LT_PARM), ONE_WT ! 1 pt rule REAL(DP) :: UGN_TAU ! ugn REAL(DP) :: S1_TAU, S3_TAU ! s1_norm, s3_norm REAL(DP) :: NORM_C, NORM_K_BAR ! array norms !b REAL(DP) :: GET_SQ_NORM ! for S1_TAU LOGICAL, SAVE :: FIRST_CALL = .TRUE. IF ( FIRST_CALL ) THEN ! one time calculations FIRST_CALL = .FALSE. !--> DEFINE GLOBAL PROPERTIES ! Misc reals are: 1-Sigma 2-Kappa 3-Rho 4-r 5-Theta 6-Lamda 7-Q Sigma = 0.9d0 ; Kappa = 5 ; Rho = 0.1d0 ! Clarke-Parrott Rate = 0.1d0 ; Theta = 0.16d0 ! Clarke-Parrott Lamda = 0 ; Source = 0 ! Clarke-Parrott IF ( REALS > 0 ) Sigma = GET_REAL_MISC (1) IF ( REALS > 1 ) Kappa = GET_REAL_MISC (2) IF ( REALS > 2 ) Rho = GET_REAL_MISC (3) IF ( REALS > 3 ) Rate = GET_REAL_MISC (4) IF ( REALS > 4 ) Theta = GET_REAL_MISC (5) IF ( REALS > 5 ) Lamda = GET_REAL_MISC (6) IF ( REALS > 6 ) Source = GET_REAL_MISC (7) END IF ! FIRST CALL ! Initialize element S_M = 0 ; S_C = 0 ; S_K = 0 TAU = 0 ; GEOM_TAU = 0 ; UGN_TAU = 0 ; S1_TAU = 0 !b Max_Pe = 0 ; PECLET = 0 ; ALPHA = 1 !b CENTER = SUM ( COORD, DIM=1 ) / LT_N ! center point CALL APPLICATION_E_MATRIX (IE, CENTER, E) ! constitutive NORM_E = SQRT ( SUM ( E **2 ) ) / SIZE ( E, 1) ! E norm !b call at(91); print *,'SUPG, TAU_S1 ', SUPG, TAU_S1 IF ( SUPG ) THEN ! Streamline Upwind Petrov-Galerkin additions ! INITIALIZE STABILIZATION ARRAYS S_UP = 0.d0 ; C_UP = 0.d0 ; H_INTG = 0.d0 S_K_BAR = 0.d0 ; S_R_BAR = 0.d0 ! GET CENTER VELOCITY AND DIFFUSION !b CALL STOCASTIC_VOLATILITY_VECTOR (CENTER, U) XYZ = CENTER U (1) = -(Rate - XYZ (2) - Rho * Sigma / 2) * XYZ (1) U (2) = -Kappa * (Theta - XYZ (2)) + Sigma * Sigma / 2 & + (Lamda + Rho * Sigma / 2) * XYZ (2) CALL UNIT_VECTOR_FORM (U, UNIT_V, SPEED) IF ( SPEED <= NIL ) THEN MOVING = .FALSE. SPEED = NIL ! Avoid / 0 and 0 / 0 U = NIL ! for N_SPACE components UNIT_V = 1.d0 / SQRT (DBLE(N_SPACE)) ! for N_SPACE components END IF ! almost zero convection SPEED_CG = SPEED ! save XYZ & velocity to plot N_FILE5.DAT IF ( N_FILE5 > 0 ) WRITE (N_FILE5, '( (10(1PE13.5)) )') CENTER, U ! GET DIFFUSION ALONG STREAMLINE CALL DIFFUSION_LOCAL (E, UNIT_V, E_UP) ! // to streamline IF ( E_UP <= 0.d0 ) STOP 'ELEM_SQ_MATRIX: INVALID E_UP <= 0' IF ( TAU_GEOM .OR. TAU_VOL .OR. TAU_SHOW ) THEN !b CALL GET_RADIALS_FROM_CENTER (CENTER, RADIAL) CALL GET_DOWNWIND_LOGIC (RADIAL, UNIT_V, DOWN, IS_DOWNWIND) CALL GET_MAX_DOWNWIND_DIST (DOWN, DOWN_NODAL) END IF IF ( TAU_GEOM .OR. TAU_SHOW ) THEN !b GEOM_H = ABS (MINVAL (DOWN)) + MAXVAL (DOWN) !b PECLET = 0.5d0 * SPEED * GEOM_H / E_UP !b CALL PECLET_OPTIMAL_RULE (PECLET, ALPHA) !b GEOM_TAU = 0.5d0 * GEOM_H * ALPHA / SPEED !b END IF ! Tau_geom IF ( TAU_UGN .OR. TAU_SHOW ) THEN CALL GET_ONE_PT_RULE (ONE_PT, ONE_WT) ! local point CALL SCALAR_DERIVS (ONE_PT, DLH) ! deriv of H AJ = MATMUL (DLH, COORD) ! Jacobian, J CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) ! Inverse of J DGH = MATMUL (AJ_INV, DLH) ! Del H U_DGH = MATMUL (U, DGH) ! u dot Del H UGN_TAU = 1.d0 / SUM ( ABS (U_DGH) ) ! Tau ugn value END IF ! Tau_ugn END IF ! Initialize upwinding ! STORE NUMBER OF POINTS FOR FLUX CALCULATIONS CALL STORE_FLUX_POINT_COUNT ! Save LT_QP !--> NUMERICAL INTEGRATION LOOP DO IP = 1, LT_QP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT ! FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) CONST = DET * WT(IP) ! local measure H_INTG = H_INTG + H * CONST ! H integral ! EVALUATE GLOBAL DERIVATIVES, DGH == B DGH = MATMUL (AJ_INV, DLH) ! Physical gradient B = COPY_DGH_INTO_B_MATRIX (DGH) ! B = DGH ! VARIABLE VOLUMETRIC SOURCE, via keyword use_exact_source ! Defaults to file my_exact_source_inc if no exact_case key IF ( USE_EXACT_SOURCE ) CALL & ! analytic Q SELECT_EXACT_SOURCE (XYZ, SOURCE) ! via exact_case key ! GALERKIN SOURCE TERM C = C + CONST * SOURCE * H ! source resultant ! VARIABLE E MATRIX IF ( VARY_E ) E = GET_APPLICATION_E_MATRIX (IE, XYZ) ! DIFFUSION SQUARE MATRIX S_K = S_K + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) ! ADD RATE SQUARE MATRIX from -r*P S_M = S_M + RATE * OUTER_PRODUCT (H, H) * CONST ! SET STREAMLINE DIRECTION !b CALL STOCASTIC_VOLATILITY_VECTOR (XYZ, U) U (1) = -(Rate - XYZ (2) - Rho * Sigma / 2) * XYZ (1) U (2) = -Kappa * (Theta - XYZ (2)) + Sigma * Sigma / 2 & + (Lamda + Rho * Sigma / 2) * XYZ (2) CALL UNIT_VECTOR_FORM (U, UNIT_V, SPEED) ! ADVECTION SQUARE MATRIX -u*Grad_P U_DGH = MATMUL (U, DGH) ! vel dot grad H S_C = S_C + OUTER_PRODUCT (H, U_DGH)*CONST ! no upwind IF ( SUPG ) THEN ! UPWIND AT QP ! GET DIFFUSION ALONG STREAMLINE !b CALL DIFFUSION_LOCAL (E, UNIT_V, E_UP) !b IF ( E_UP < 0.d0 ) STOP 'ELEM_SQ_MATRIX: INVALID E_UP < 0' ! FORM STABILIZATION ARRAYS (LESS Tau SCALE) C_UP = C_UP + SOURCE * U_DGH * CONST S_R_BAR = S_R_BAR + OUTER_PRODUCT (U_DGH, H) * RATE * CONST S_K_BAR = S_K_BAR + OUTER_PRODUCT (U_DGH, U_DGH) * CONST ! - E * 2nd deriv, now neglected !b XXX IF ( GET_2ND_DERIV ) THEN ! add 2nd derivative terms ! EXACT 3: U,xx U,yx=U,xy U,yy ! FE 4: U,xx U,yx U,xy U,yy ! Get second derivatives, un-smoothed CALL JACOBIAN_PRODUCTS (AJ, P_AJ) ! ALWAYS NEEDED ! NOTE: D2GH = P_AJ_INV (D2LH - HESSIAN * DGH) ! HESSIAN = D2LH * COORD CALL INV_SMALL_MAT (N_2_DER, P_AJ, P_AJ_INV, I_ERROR) IF ( I_ERROR > 0 ) THEN PRINT *, 'ERROR: SUPG w 2ND DERIV, NO PRODUCT INVERSE' STOP 'ERROR: SUPG w 2ND DERIV, NO PRODUCT INVERSE' END IF ! INVERSION ERROR CALL SCALAR_2ND_DERIVS (PT(:, IP), D2LH) ! some elem only IF ( CONSTANT_J ) THEN ! AJ constant so Hessian == 0 D2GH = MATMUL (P_AJ_INV, D2LH) ELSE ! use full Hessian matrix D2GH = MATMUL (P_AJ_INV, (D2LH & - MATMUL (MATMUL (D2LH, COORD), DGH))) END IF ! ZERO HESSIAN ! complete matrix products, H' (E x D2GH) E_VECTOR = PACK (E, .TRUE.) E_D2GH (:) = DOT_PRODUCT (E_VECTOR, & PACK (D2GH (1:N_2_DER, :), .TRUE.) ) S_K_BAR = S_K_BAR + OUTER_PRODUCT (H, E_D2GH) * CONST END IF ! 2nd deriv END IF ! VARIABLE UPWIND !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO ! for integration S = S_K + S_M + S_C ! if no upwinding IF ( DEBUG_EL_SQ .AND. THIS_EL < 3 ) THEN print *,'S_K '; call rprint (S_K , LT_FREE, LT_FREE,1) print *,'S_M '; call rprint (S_M , LT_FREE, LT_FREE,1) print *,'S_C '; call rprint (S_C , LT_FREE, LT_FREE,1) print *,'C '; call rprint (C , 1, LT_FREE,1) IF ( SUPG ) THEN print *,'S_K_BAR '; call rprint (S_K_BAR, LT_FREE, LT_FREE,1) print *,'S_R_BAR '; call rprint (S_R_BAR, LT_FREE, LT_FREE,1) print *,'C_UP '; call rprint (C_UP , 1, LT_FREE,1) END IF END IF ! debug IF ( TAU_VOL .OR. TAU_SHOW ) THEN ! integral average DW dist VOL_H = DOT_PRODUCT (H_INTG, DOWN_NODAL) & !b / SUM (H_INTG) ! integral average !b PECLET = 0.5d0 * SPEED * VOL_H / E_UP !b CALL PECLET_OPTIMAL_RULE (PECLET, ALPHA) !b VOL_TAU = 0.5d0 * VOL_H * ALPHA / SPEED !b END IF ! Tau geom IF ( SUPG ) THEN ! STABILIZE SOLUTION IF ( TAU_S1 .OR. TAU_SHOW ) THEN NORM_C = SQRT ( SUM ( S_C **2 ) ) / SIZE ( S_C, 1) NORM_K_BAR = SQRT ( SUM ( S_K_BAR **2 ) ) / SIZE ( S_K_BAR, 1) S1_TAU = NORM_C / NORM_K_BAR RE_ELEM = SPEED_CG **2 * S1_TAU / NORM_E S3_TAU = RE_ELEM * S1_TAU END IF if ( THIS_EL <= 3 ) THEN print *, 'TAU_S1 ', TAU_S1 print *, 'THIS_EL, S1_TAU, NORM_E, SPEED_CG, RE_ELEM, S3_TAU' print *, THIS_EL, S1_TAU, NORM_E, SPEED_CG, RE_ELEM, S3_TAU end if IF ( PECLET > Max_Pe ) Max_Pe = PECLET IF (IE == N_ELEMS) PRINT *,'Maximum element Pe = ', Max_Pe IF ( TAU_GEOM ) THEN TAU = GEOM_TAU ELSEIF ( TAU_UGN ) THEN TAU = UGN_TAU ELSEIF ( TAU_VOL ) THEN TAU = VOL_TAU ELSEIF ( TAU_S1 ) THEN !b TAU = S1_TAU TAU = 1.d0 / SQRT ( 1 / S1_TAU **2 + 1 / S3_TAU **2 ) ELSE TAU = S1_TAU !b BOX_TAU END IF ! user selection IF ( TAU_SHOW .AND. THIS_EL == 1 ) THEN print *,'GEOM_T ', GEOM_TAU print *,'S1_T ', S1_TAU print *,'UGN_T VOL_T ', UGN_TAU, VOL_TAU print *,'TAU ', TAU END IF C = C + C_UP * TAU S_UP = (S_K_BAR + S_R_BAR) * TAU S = S + S_UP END IF ! SUPG IF ( DEBUG_EL_SQ .AND. THIS_EL < 3 ) THEN IF ( SUPG ) THEN print *,'S_UP '; call rprint (S_UP , LT_FREE, LT_FREE,1) END IF print *,'S '; call rprint (S , LT_FREE, LT_FREE,1) print *,'C '; call rprint (C , 1, LT_FREE,1) END IF ! debug ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_213 ! ============= End Files for EXAMPLE number 213 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 214 ============= SUBROUTINE DESCRIBE_EXAMPLE_214 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 214 ***' PRINT *, 'Fully numerically integrated 1-, 2-, 3-D or ' PRINT *, 'axisymmetric anisotropic Transient Poisson Equation:' PRINT *, 'K_x T,xx + 2K_xy T,xy + K_y T,yy + Q - R T,t = 0' PRINT *, '(Example 214 is Example 209 plus the mass matrix)' PRINT *, '' PRINT *, 'Standard Element Properties assumed: ' PRINT *, '1-D problem, K_xx, Q, Thickness, R' PRINT *, '2-D problem, K_xx, K_yy, K_xy, Q, Thickness, R' PRINT *, '3-D problem, K_xx, K_yy, K_zz, K_xy, K_xz, K_yz, Q, R' PRINT *, 'R = rho * c_p' PRINT *, '' PRINT *, 'Convection Element Properties assumed:' PRINT *, 'Point: h, T_inf, Area' PRINT *, 'Line: h, T_inf, Thickness' PRINT *, 'Face: h, T_inf' PRINT *, '' PRINT *, 'Default Initial Condition: T(xyz,0) = start_value (=0)' END SUBROUTINE DESCRIBE_EXAMPLE_214 SUBROUTINE ELEM_SQ_EX_214 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE 214 includes EL_M matrix Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! NOW USING MASS MATRIX EL_M (LT_FREE, LT_FREE) ALSO ! .............................................................. ! TRANSIENT ANISOTROPIC POISSON EQUATION IN 1-, 2-, or 3-D ! VIA NUMERICALLY INTEGRATED ELEMENTS ! (K_ij * U,i),j + Q - Rho * U,t = 0; 1 <= (i,j) <= N_SPACE REAL(DP) :: CONST, DET ! integration REAL(DP), SAVE :: SOURCE=0.d0, RHO=1.d0, THICK=1.d0 ! data INTEGER :: IP ! counter ! Properties assumed, (order in GET_REAL_LP (n)): ! 1-D problem, K_xx, Q, Thickness, Rho ! 2-D problem, K_xx, K_yy, K_xy, Q, Thickness, Rho ! 3-D problem, K_xx, K_yy, K_zz, K_xy, K_xz, K_yz, Q, Rho ! Default Initial Condition: T(xyz,0) = start_value keyword (=0) CALL POISSON_ANISOTROPIC_E_MATRIX (E) ! for 1-, 2-, or 3-D IF ( SCALAR_SOURCE /= 0.d0 ) SOURCE = SCALAR_SOURCE IF ( AREA_THICK /= 1.d0 ) THICK = AREA_THICK IF ( EL_REAL > 0 ) THEN ! Get local element constant values, SELECT CASE (N_SPACE) ! for source, thickness, or rho CASE (1) ; IF ( EL_REAL > 1 ) SOURCE = GET_REAL_LP (2) IF ( EL_REAL > 2 ) THICK = GET_REAL_LP (3) IF ( EL_REAL > 3 ) RHO = GET_REAL_LP (4) CASE (2) ; IF ( EL_REAL > 3 ) SOURCE = GET_REAL_LP (4) IF ( EL_REAL > 4 ) THICK = GET_REAL_LP (5) IF ( EL_REAL > 5 ) RHO = GET_REAL_LP (6) CASE (3) ; IF ( EL_REAL > 6 ) SOURCE = GET_REAL_LP (7) IF ( EL_REAL > 7 ) RHO = GET_REAL_LP (8) END SELECT END IF ! element data provided CALL STORE_FLUX_POINT_COUNT ! Save LT_QP, for post-process DO IP = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IP) ! EVALUATE INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, ISOPARAMETRIC DLH = GET_DLH_AT_QP (IP) ! FIND LOCAL DERIVATIVES AJ = MATMUL (DLH, COORD) ! FIND JACOBIAN AT THE PT CALL INVERT_JACOBIAN (AJ, AJ_INV, DET, N_SPACE) ! inverse IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IP) * THICK DGH = MATMUL (AJ_INV, DLH) ; B = DGH ! Physical gradient !b B = COPY_DGH_INTO_B_MATRIX (DGH) ! B = DGH ! VARIABLE VOLUMETRIC SOURCE, via keyword use_exact_source ! Defaults to file my_exact_source_inc if no exact_case key IF ( USE_EXACT_SOURCE ) CALL & ! analytic Q SELECT_EXACT_SOURCE (XYZ, SOURCE) ! via exact_case key C = C + CONST * SOURCE * H ! source resultant ! CONDUCTION SQUARE MATRIX, MASS MATRIX S = S + CONST * MATMUL ((MATMUL (TRANSPOSE (B), E)), B) EL_M = EL_M + OUTER_PRODUCT (H, H) * CONST * RHO IF ( DEBUG_EL_SQ ) THEN PRINT *, 'Debug THIS_EL, THICK ', THIS_EL, THICK PRINT *, 'S ' ; CALL RPRINT (S, LT_FREE, LT_FREE, 1) PRINT *, 'M ' ; CALL RPRINT (EL_M, LT_FREE, LT_FREE, 1) PRINT *, 'C ' ; CALL RPRINT (C, 1, LT_FREE, 1) END IF !--> SAVE COORDS, E AND DERIVATIVE MATRIX, FOR POST PROCESSING CALL STORE_FLUX_POINT_DATA (XYZ, (E * THICK), B) END DO ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_214 SUBROUTINE MIXED_SQ_EX_214 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE MIXED_BC SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** MIXED_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .............................................................. ! Mixed or Robin boundary condition, Standard form: ! K_n * U,n + ROBIN_1_SEG * U + ROBIN_2_SEG = 0 ! Set in keywords robin_square and robin_column ! H_INTG (LT_N) Integral of H available to store INTEGER :: IQ ! Integration loop REAL(DP) :: CONST, DET, THICK ! face area IF ( N_FILE2 > 0 ) H_INTG = 0 ! via post_mixed, for post_process ! GET ROBIN TERMS, IF GLOBAL CONSTANTS ! Set in keywords robin_square and robin_column, or via ! convect_coef, convect_temp for convection special case THICK = 1.d0 ! if an edge IF ( CONVECTION ) THEN ! constant convection all segments ROBIN_1_SEG = CONVECT_COEF ROBIN_2_SEG = -CONVECT_COEF * CONVECT_TEMP !b !b ROBIN_2_SEG = CONVECT_COEF * CONVECT_TEMP ! XXX check sign IF ( LT_PARM < 2 ) THICK = CONVECT_THICK ! point or line END IF ! Convection ! GET ROBIN TERMS, IF LOCAL SEGMENT CONSTANTS IF ( MIXED_REAL > 0 ) THEN ! are local data IF ( CONVECT_VARY ) THEN ! data are coeff, temperature, thick ROBIN_1_SEG = GET_REAL_MX (1) ! convection coeff ROBIN_2_SEG = 0.d0 ! default temperature effect IF ( MIXED_REAL > 1 ) ROBIN_2_SEG = -ROBIN_1_SEG & * GET_REAL_MX (2) ! coeff*temp IF ( MIXED_REAL > 2 .AND. LT_PARM < 2 ) THICK = GET_REAL_MX (3) ELSE ! a non-convection Robin condition ROBIN_1_SEG = GET_REAL_MX (1) ; ROBIN_2_SEG = 0.d0 IF ( MIXED_REAL > 1 ) ROBIN_2_SEG = GET_REAL_MX (2) IF ( MIXED_REAL > 2 .AND. LT_PARM < 2 ) THICK = GET_REAL_MX (3) !b IF ( MIXED_REAL > 2 ) THICK = GET_REAL_MX (3) END IF ! convection or general Robin data END IF ! local data IF ( LT_N > 1 ) THEN ! Not a single point, must integrate DO IQ = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IQ) ! BOUNDARY INTERPOLATION FUNCTIONS XYZ = MATMUL (H, COORD) ! FIND GLOBAL COORD, (ISOPARAMETRIC) DLH = GET_DLH_AT_QP (IQ) ! FIND LOCAL DERIVATIVES ! FORM DETERMINATE OF GENERALIZED JACOBIAN, Fig 5.4.2 DET = PARM_GEOM_METRIC (DLH, COORD) ! dX / dr IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IQ) * THICK IF ( N_FILE2 > 0 ) H_INTG = H_INTG + H * DET * WT(IQ) ! GET VARIABLE ROBIN DATA, via use_exact_robin keyword IF ( USE_EXACT_ROBIN ) CALL SELECT_EXACT_ROBIN_DATA & (XYZ, ROBIN_1_SEG, ROBIN_2_SEG) S = S + ROBIN_1_SEG * CONST * OUTER_PRODUCT (H, H) ! Sq C = C - ROBIN_2_SEG * CONST * H ! Source END DO ELSE ! This is a point value, maybe analytic expression IF ( AXISYMMETRIC ) THICK = TWO_PI * COORD (1, 1) IF ( USE_EXACT_ROBIN ) CALL SELECT_EXACT_ROBIN_DATA & (COORD (1, :), ROBIN_1_SEG, ROBIN_2_SEG) S (1, 1) = ROBIN_1_SEG * THICK C (1) = -ROBIN_2_SEG * THICK IF ( N_FILE2 > 0 ) H_INTG = THICK ! actually area at pt, input END IF ! boundary segment type IF ( N_FILE2 > 0 ) WRITE (N_FILE2) H_INTG ! via post_mixed IF ( DEBUG_MIX_SQ ) THEN PRINT *, 'Debug THIS_EL ', THIS_EL PRINT *, 'Smixed ' ; CALL RPRINT (S, LT_FREE, LT_FREE, 1) PRINT *, 'Cmixed ' ; CALL RPRINT (C, 1, LT_FREE, 1) PRINT *, 'Hntgrl ' ; CALL RPRINT ( H_INTG, 1, LT_FREE, 1) END IF ! End mixed condition BC 214.my_mixed_sq_inc ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE MIXED_SQ_EX_214 SUBROUTINE SEG_COL_EX_214 (E, H_INTG, PRT_L_PT, PRT_MAT,& L_PT_PROP, IE, FLUX) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE FLUX SEGMENT COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Geometric_Properties Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! OPTIONAL FLUX VALUES IF BOUNDARY SEGMENT ELEMENT REAL(DP), INTENT(IN) :: FLUX (L_B_N, N_G_FLUX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & XYZ (N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), H_INTG (LT_N), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! ..................................................... ! *** SEG_COL_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! ..................................................... ! Given normal flux on an element face or edge: ! Standard form: -K_n * U,n = Q_NORMAL_SEG (in System_Constants) INTEGER :: IQ ! loops REAL(DP) :: CONST, DET, THICK ! flux area ! Get normal flux from keyword, or segment property IF ( SEG_REAL > 0 ) Q_NORMAL_SEG= GET_REAL_SP (1) THICK = 1 ! Default flux line segment real property # 2 IF ( SEG_REAL > 1 ) THICK = GET_REAL_SP (2) IF ( LT_N > 1 ) THEN ! Not a point value DO IQ = 1, LT_QP ! NUMERICAL INTEGRATION LOOP H = GET_H_AT_QP (IQ) ! BOUNDARY INTERPOLATION FUNCTIONS ! FIND GLOBAL COORD, XYZ = H*COORD (ISOPARAMETRIC) XYZ = MATMUL (H, COORD) ! FIND LOCAL DERIVATIVES DLH = GET_DLH_AT_QP (IQ) ! FORM DETERMINATE OF GENERALIZED JACOBIAN DET = PARM_GEOM_METRIC (DLH, COORD) ! dX / dr IF ( AXISYMMETRIC ) THICK = TWO_PI * XYZ (1) ! via axisymmetric CONST = DET * WT(IQ) * THICK ! GET NORMAL FLUX COMPONENT IF ( USE_EXACT_FLUX ) CALL SELECT_EXACT_NORMAL_FLUX & (XYZ, Q_NORMAL_SEG) ! via keyword use_exact_flux C = C + Q_NORMAL_SEG * CONST * H ! Source vector END DO ELSE ! This is a point value IF ( USE_EXACT_FLUX ) CALL SELECT_EXACT_NORMAL_FLUX & (COORD (1, :), Q_NORMAL_SEG) ! via use_exact_flux C (1) = Q_NORMAL_SEG END IF ! boundary segment type ! End application dependent flux ! suppress compiler warnings (never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, FLUX END SUBROUTINE SEG_COL_EX_214 SUBROUTINE POST_PROCESS_MIXED_EX_214 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! MIXED SEGMENT POST-SOLUTION CALCULATIONS ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, MIXEDENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_MIXED PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! Define any new array or variable types, then give statements ! Global CONVECT_COEF set by keyword convect_coeff is available ! Global CONVECT_TEMP set by keyword convect_temp is available ! H_INTG (LT_N) Integral of interpolation functions, H, available ! convection heat loss recover REAL(DP) :: THICK ! line width REAL(DP), SAVE :: Q_LOSS, TOTAL = 0.d0 ! Face and total heat loss LOGICAL, SAVE :: FIRST = .TRUE. ! printing IF ( FIRST ) THEN ! first call FIRST = .FALSE. ; WRITE (6, 5) ! print headings 5 FORMAT ('*** CONVECTION HEAT LOSS ***', /, & & 'ELEMENT HEAT_LOST') END IF ! first call IF ( N_FILE2 > 0 .and. LT_QP > 1 ) THEN ! H already integrated READ (N_FILE2) H_INTG ! via post_mixed ELSE ! compute it here PRINT *,'WARNING: NEED post_mixed IN CONTROL' N_WARN = N_WARN + 1 STOP 'POST_PROCESS_MIXED 208,209, or 302 ERROR 1' END IF ! H_INTG ! Get convection coff and temp, maybe thickness ! GET ROBIN TERMS, IF GLOBAL CONSTANTS ! Set in keywords robin_square and robin_column, or via ! convect_coef, convect_temp for convection special case THICK = 1.d0 ! if an edge IF ( CONVECTION ) THEN ! constant convection all segments ! Then CONVECT_COEF, CONVECT_TEMP, CONVECT_THICK global IF ( LT_PARM < 2 ) THICK = CONVECT_THICK ! point or line END IF ! Convection ! GET ROBIN TERMS, IF LOCAL SEGMENT CONSTANTS IF ( MIXED_REAL > 0 ) THEN ! are local data IF ( CONVECT_VARY ) THEN ! data are coeff, temperature, thick CONVECT_COEF = GET_REAL_MX (1) ! convection coeff CONVECT_TEMP = 0.d0 ! default temperature effect IF ( MIXED_REAL > 1 ) CONVECT_TEMP = GET_REAL_MX (2) ! temp IF (MIXED_REAL > 2 .AND. LT_PARM < 2) THICK = GET_REAL_MX (3) ELSE ! a non-convection Robin condition PRINT *,'WARNING: NEED KEY convect_coef OR convect_vary ' N_WARN = N_WARN + 1 STOP 'POST_PROCESS_MIXED 208,209, or 302 ERROR 2' END IF END IF ! local data IF ( DEBUG_MIX_SQ .OR. DEBUG_POST_EL ) THEN PRINT *, 'H Integral for element ' , THIS_EL CALL RPRINT ( H_INTG, 1, LT_FREE, 1) END IF ! HEAT LOST FROM THIS FACE: Integral over face of h * (T - T_inf) D (1:LT_N) = D(1:LT_N) - CONVECT_TEMP ! Temp difference at nodes Q_LOSS = CONVECT_COEF * DOT_PRODUCT (H_INTG, D) ! Face loss IF ( LT_PARM < 2 ) Q_LOSS = Q_LOSS * THICK ! line or point TOTAL = TOTAL + Q_LOSS ! Running total PRINT '(I6, ES15.5)', IE, Q_LOSS IF ( IE == N_MIXED ) PRINT *, 'TOTAL = ', TOTAL ! *** END POST_PROCESS_MIXED PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_MIXED_EX_214 ! ============= End Files for EXAMPLE number 214 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 215 ============= SUBROUTINE DESCRIBE_EXAMPLE_215 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 215 ***' PRINT *, 'Isotropic plane strain analysis, including mass matrix.' PRINT *, 'Two unknown displacents per node, and three active ' PRINT *, 'strain and stress components, S_xx, S_yy, S_xy.' PRINT *, 'Four post processed stress components, above plus the' PRINT *, 'Von Mises failure criterion' END SUBROUTINE DESCRIBE_EXAMPLE_215 SUBROUTINE ELEM_SQ_EX_215 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! PLANE_STRAIN ANALYSIS, NON-ISOPARAMETRIC ! STATIC or DYNAMIC (with EL_M & DAMP (LT_FREE, LT_FREE)) ! or BODY_FORCE (N_SPACE) via keyord control ! ------------------------------------------------------------ ! STRESS AND STRAIN COMPONENT ORDER: XX, YY, XY, SO N_R_B = 3 ! LATER PLUS ZZ & EFFECTIVE AS N_R_B + 1 & 2 INTEGER :: IP ! loops REAL(DP) :: DET, DET_WT ! volume REAL(DP) :: N_e (N_G_DOF, LT_FREE) ! interpolation REAL(DP), SAVE :: RHO=1.d0 ! data ! N_G_DOF = NUMBER OF GENERALIZED PARAMETERS (DOF) PER NODE ! PROPERTIES: 1-YOUNG'S MODULUS, 2-POISSON'S RATIO, AND ! 3-YIELD STRESS, IF PRESENT, 4-MASS DENSITY, IF PRESENT IF ( EL_REAL > 3 ) RHO = GET_REAL_LP (4) ! Mass density N_e = 0.d0 ! Save zeros CALL STORE_FLUX_POINT_COUNT ! Save LT_QP ! FORM THE CONSTITUTIVE MATRIX (OR GET_APPLICATION_E_MATRIX) CALL E_PLANE_STRAIN (E) DO IP = 1, LT_QP ! NUMERICAL INTEGRATION LOOP G = GET_G_AT_QP (IP) ! GEOMETRY INTERPOLATIONS GEOMETRY = COORD (1:LT_GEOM,:) ! GEOMETRY NODES XYZ = MATMUL (G, GEOMETRY) ! COORDINATES OF POINT DLG = GET_DLG_AT_QP (IP) ! GEOMETRIC DERIVATIVES AJ = GEOMETRIC_JACOBIAN () ! JACOBIAN CALL INVERT_2BY2 (AJ, AJ_INV, DET) ! INVERSE, DET DET_WT = DET * WT (IP) H = GET_H_AT_QP (IP) ! SCALAR INTERPOLATIONS N_e (1, 1:LT_FREE:2) = H ! Fill vector interpolations N_e (2, 2:LT_FREE:2) = H ! Fill vector interpolations DLH = GET_DLH_AT_QP (IP) ! SCALAR DERIVATIVES DGH = MATMUL (AJ_INV, DLH) ! PHYSICAL DERIVATIVES !---> FORM STRAIN DISPLACEMENT, B (OR GET_APPLICATION_B_MATRIX) CALL ELASTIC_B_PLANAR (DGH, B) ! EVALUATE ELEMENT STIFFNESS, MASS MATRICES S = S + DET_WT * MATMUL (TRANSPOSE(B), MATMUL (E, B)) EL_M = EL_M + MATMUL (TRANSPOSE(N_e), N_e) * DET_WT * RHO ! EVALUATE ANY BODY FORCE RESULTANTS IF ( HAS_BODY_FORCE ) THEN C = C + MATMUL (TRANSPOSE(N_e), BODY_FORCE(1:2)) * DET_WT END IF ! SAVE PT, CONSTITUTIVE & STRAIN_DISP FOR POST_PROCESS & SCP CALL STORE_FLUX_POINT_DATA (XYZ, E, B) END DO ! Over quadrature points ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_215 SUBROUTINE POST_PROCESS_ELEM_EX_215 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_215 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! STATIC PLANE_STRESS OR PLANE_STRAIN ANALYSIS ! ------------------------------------------------------------- ! STRESS AND STRAIN COMPONENT ORDER: XX, YY, XY, SO N_R_B = 3 ! PLUS ZZ & EFFECTIVE ARE N_R_B + 1 & 2 ! PROPERTIES: 1-YOUNG'S MODULUS, 2-POISSON'S RATIO, AND ! 3-YIELD STRESS, IF PRESENT ! 4-MASS DENSITY, IF PRESENT INTEGER :: J, N_IP ! loops REAL(DP), SAVE :: YIELD = HUGE (1.d0) ! failure REAL(DP), SAVE :: PR = 0.25d0, RHO=1.d0 ! data IF ( THIS_EL == 1 ) THEN ! PRINT TITLES & INITIALIZE STRAIN = 0.d0 ; STRAIN_0 = 0.d0 ! INITIALIZE ALL "STRESS" IF ( PLANE_STRAIN ) PRINT *, 'NOTE: USING PLANE STRAIN STATE' WRITE (6, 50) ; 50 FORMAT ( /, & '*** STRESSES AT INTEGRATION POINTS ***', /, & ' COORDINATES STRESSES', /, & 'POINT X Y XX YY XY', /, & 'POINT ZZ EFFECTIVE') END IF ! NEW HEADINGS IF ( EL_REAL > 1 ) PR = GET_REAL_LP (2) ! set Poisson ratio IF ( EL_REAL > 2 ) YIELD = GET_REAL_LP (3) ! set yield WRITE (6, * ) ' ELEMENT NUMBER ', IE CALL READ_FLUX_POINT_COUNT (N_IP) ! NUMBER OF QUADRATURE POINTS DO J = 1, N_IP ! QUADRATURE POINT LOOP CALL READ_FLUX_POINT_DATA (XYZ, E, B) ! PT, PROP, STRAIN_DISP ! MECHANICAL STRAINS & STRESSES STRAIN (1:N_R_B) = MATMUL (B, D) ! STRAINS AT THE POINT STRESS (1:N_R_B) = MATMUL (E, STRAIN (1:N_R_B)) ! STRESSES ! Z-STRESS INDUCED, ELSE ZERO IN PLANE STRESS IF ( PLANE_STRAIN ) STRESS (4) = PR * (STRESS (1) + STRESS (2)) ! VON_MISES FAILURE CRITERION (EFFECTIVE STRESS, ADD TO END) STRESS (5) = SQRT ( (STRESS (1) - STRESS (2) ) **2 & + (STRESS (2) - STRESS (4) ) **2 & + (STRESS (4) - STRESS (1) ) **2 & + 6 * STRESS (3) **2 ) * 0.707106812d0 IF ( STRESS (5) >= YIELD ) PRINT *, & 'WARNING: FAILURE CRITERION EXCEEDED IN ELEMENT =', IE ! LIST STRESSES AND FAILURE CRITERION AT POINT WRITE (6, 52) J, XYZ (1:2), STRESS (1:3) WRITE (6, 51) J, STRESS (4:5) 52 FORMAT ( I3, 2(1PE11.3), 5(1PE14.5) ) 51 FORMAT ( I3, 22X, 5(1PE14.5) ) END DO ! AT QUADRATURE POINTS ! *** END POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_215 ! ============= End Files for EXAMPLE number 215 ============= ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 301 ============= SUBROUTINE DESCRIBE_EXAMPLE_301 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 301 ***' PRINT *, ' SPACE FRAME MEMBER' PRINT *, ' ------------------' PRINT *, ' LOCAL AXES BELOW:' PRINT *, ' Y, MINOR AXIS OF MEMBER CROSS_SECTION IS || TO THE Y-AXIS' PRINT *, ' |' PRINT *, ' * 3, IF THREE NODES GIVEN, THIRD ONE DEFINES LOCAL Y' PRINT *, ' | ELSE, LOCAL Y IS FALLS IN GLOBAL Y, LOCAL X PLANE' PRINT *, ' |' PRINT *, ' |1 2' PRINT *, ' *------(e)-------* ---> X, MEMBER LENGTH IS ALONG X-AXIS' PRINT *, ' /' PRINT *, ' /' PRINT *, 'Z, MAJOR AXIS OF MEMBER CROSS_SECTION IS || TO THE Z-AXIS' END SUBROUTINE DESCRIBE_EXAMPLE_301 SUBROUTINE ELEM_SQ_EX_301 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE, X) ! for ref node !b L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu REAL(DP), INTENT(IN) :: X (MAX_NP, N_SPACE) ! Global coordinates ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! NOTE: IS_ELEMENT SHOULD BE TRUE HERE ! .............................................................. ! Define any new array or variable types, then give statements ! SPACE FRAME MEMBER ! ------------------ ! ! LOCAL AXES BELOW: ! Y, MINOR AXIS OF MEMBER CROSS_SECTION IS || TO THE Y-AXIS ! | ! * 3, IF THREE NODES GIVEN, THIRD ONE DEFINES LOCAL Y ! | ELSE, LOCAL Y IS FALLS IN GLOBAL Y, LOCAL X PLANE ! | ! |1 2 ! *------(e)-------* ---> X, MEMBER LENGTH IS ALONG THE X-AXIS ! / ! / ! Z, MAJOR AXIS OF MEMBER CROSS_SECTION IS || TO THE Z-AXIS ! ! PROPERTIES: 1 AREA, 2 IX, 3 IY, 4 IZ, 5 ELASTIC MODULUS ! 6 SHEAR MODULUS, 7 LOAD/LENGTH AT NODE 1, 8 LOAD/LENGTH AT NODE 2 ! 9 third node number LOGICAL :: LARGE_DISP = .FALSE. !b .TRUE. !b INTEGER :: I, I1, I2, I3, I4 ! Loops INTEGER :: J, J1, J2, J3, J4 ! Loops !b INTEGER :: NODE_3, LP_REAL INTEGER :: NODE_3 REAL(DP), PARAMETER :: G_GLOBAL (3) = (/ 0.d0, -1.d0, 0.d0 /) REAL(DP) :: BAR_L, BAR_L2, BAR_L4 REAL(DP) :: CX, CY, CZ, Q REAL(DP) :: D_LOCAL (12), FORCE REAL(DP) :: C_LOCAL (12) REAL(DP) :: G_LOCAL ( 3) REAL(DP) :: R_LOCAL (12), FORCE_REACT REAL(DP) :: ROT_3 (3, 3), ROT_12 (12, 12) REAL(DP) :: S_LOCAL (12, 12), T (4, 4) REAL(DP) :: SG_LOCAL (12, 12), TG (4, 4) REAL(DP) :: X1, Y1, Z1, X2, Y2, Z2, DX, DY, DZ ! 2 pts in 3-d REAL(DP) :: XYZ_3 (3), XYZ_3S (3), XYZ_3G (3) ! local 3rd pt geom REAL(DP) :: SIN_L, COS_L, QS ! local 3rd pt geom REAL(DP), SAVE :: AREA, IX, IY, IZ REAL(DP), SAVE :: ELASTIC, SHEAR REAL(DP), SAVE :: WPL_L, WPL_R !*** DEFINE ALL NEW VARIABLES ********************************** ! AREA - CROSS SECTIONAL AREA OF ELEMENT ! BAR_L - LENGTH OF EACH ELEMENT ! CX, CY, CZ - DIRECTION COSINE ! C21, C22, C23 - ROTATION COMPONENTS OF THE 3 X 3 TRANSFORMATION MATRIX ! C_LOCAL - LOCAL MEMBER FORCE (3 FORCES & 3 MOMENTS EACH END) ! DX, DY, DZ - MEMBER LENGTH ! D_LOCAL - LOCAL DISPLACEMENT OF MEMBER ! ELASTIC - MODULUS OF ELASTICITY OF MEMBER ! FORCE - AXIAL FORCE IN A MEMBER ! NODE_3 - THIRD OPTIONAL GEOMETRY NODE ! S_LOCAL - 12 X 12 STIFFNESS MATRIX IN LOCAL COORDINATES (3-D) ! SG_LOCAL - 12 X 12 GEOMETRICAL STIFFNESS IN LOCAL COORDINATES ! ROT_3 - 3 X 3 TRANSFORMATION MATRIX ( vector transformation) ! ROT_12 - 12 X 12 TRANSFORMATION MATRIX (6 DOF @ EACH END) ! SHEAR - SHEAR MODULUS OF ELASTICITY OF MEMBER ! T - 4 X 4 STIFFNESS MATRIX (2-D) ! TG - 4 X 4 GEOMETRICAL STIFFNESS (2-D) ! WPL_L - WEIGHT/LENGTH AT LEFT END OF MEMBER ! WPL_R - WEIGHT/LENGTH AT RIGHT END OF MEMBER !***************************************************************** !*** GET VARIOUS PROPERTIES !b LP_REAL = N_LP_FLO !b replace with COUNT_EL_REAL_ AREA = GET_REAL_LP (1) IX = GET_REAL_LP (2) IY = GET_REAL_LP (3) IZ = GET_REAL_LP (4) ELASTIC = GET_REAL_LP (5) SHEAR = GET_REAL_LP (6) !*** GET WEIGHT/LENGTH WPL_L = GET_REAL_LP (7) WPL_R = GET_REAL_LP (8) !*** GET REFERENCE NODE IF PRESENT !b IF ( LP_REAL >= 9 ) THEN ! get third reference node IF ( EL_REAL >= 9 ) THEN ! get third reference node NODE_3 = NINT (GET_REAL_LP (9)) IF ( DEBUG_EL_SQ ) PRINT *, 'IE, NODE_3 ', IE, NODE_3, & GET_REAL_LP (9) ELSE ; NODE_3 = 0 ; END IF !*** GET INITIAL AXIAL FORCE FORCE = 0.d0 !b IF ( N_LP_FLO == 2 ) THEN AREA = GET_REAL_LP (1) IZ = GET_REAL_LP (2) END IF ! SPECIAL CASE !*** INITIALIZE C_LOCAL, S_LOCAL, ROT_3, ROT_12 C_LOCAL = 0.d0 ; S_LOCAL = 0.d0 ; SG_LOCAL = 0.d0 ROT_3 = 0.d0 ; ROT_12 = 0.d0 !*** DEFINE GLOBAL COORDINATE VALUES X1 = COORD (1, 1) ; Y1 = COORD (1, 2) ; Z1 = COORD (1, 3) X2 = COORD (2, 1) ; Y2 = COORD (2, 2) ; Z2 = COORD (2, 3) !*** GET REFERENCE NODE COORDINATES IF PRESENT IF ( NODE_3 > 0 ) THEN ! third reference node XYZ_3 = X (NODE_3, :) !b needs a global function here !b IF ( DEBUG_EL_SQ ) PRINT *, 'XYZ_3 ', XYZ_3 XYZ_3S = XYZ_3 - COORD (1, :) !b IF ( DEBUG_EL_SQ ) PRINT *, 'XYZ_3S ', XYZ_3S ELSE SIN_L = 0.d0 ; COS_L = 1.d0 END IF ! END IF !*** FIND THE VECTOR CONNECTING TWO NODAL POINTS AND ITS LENGTH ! (LOCAL Z AXIS) DX = X2 - X1 ; DY = Y2 - Y1 ; DZ = Z2 - Z1 BAR_L = SQRT (DX * DX + DY * DY + DZ * DZ) BAR_L2 = BAR_L * BAR_L BAR_L4 = BAR_L2 * BAR_L2 IF ( DEBUG_EL_SQ ) THEN WRITE (N_BUG, *) 'Entering my_el_sq_inc' WRITE (6, *) 'ELEMENT NUMBER = ', IE, ' LENGTH = ', BAR_L WRITE (6, *) 'AREA = ', AREA WRITE (6, *) 'IX = ', IX WRITE (6, *) 'IY = ', IY WRITE (6, *) 'IZ = ', IZ WRITE (6, *) 'ELASTIC = ', ELASTIC WRITE (6, *) 'SHEAR = ', SHEAR WRITE (6, *) 'WPL_L = ', WPL_L WRITE (6, *) 'WPL_R = ', WPL_R WRITE (6, *) 'NODE_3 = ', NODE_3 WRITE (6, *) 'FORCE = ', FORCE END IF !*********************************************** !*** MAJOR AXIS OF A MEMBER IS || TO THE Z-AXIS !*** MINOR AXIS OF A MEMBER IS || TO THE Y-AXIS !*** MEMBER LENGTH IS ALONG THE X-AXIS !*********************************************** !*** DIRECTION COSINES CX = DX / BAR_L CY = DY / BAR_L CZ = DZ / BAR_L Q = SQRT (CX * CX + CZ * CZ) !*** BASIC TRANSFORMATION MATRIX (ROT_3) ! CHECK IF THE ELEMENT IS VERTICAL, OR NEARLY SO ! THAT IS, PARALLEL TO GLOBAL Y-AXIS IF ( Q < 0.01d0 ) THEN ! Almost vertical IF (CY >= 0.d0) CY = 1.d0 IF (CY < 0.d0) CY = - 1.d0 ROT_3 (1, 2) = CY ROT_3 (2, 1) = -CY ROT_3 (3, 3) = 1.d0 ! SPECIAL CASE FOR THIRD NODE IF ( NODE_3 > 0 ) THEN QS = SQRT ( XYZ_3S (1) **2 + XYZ_3S (3) **2 ) !b IF ( QS == 0.d0 ) THEN ! BAD DATA PRINT *, 'WARNING, ELEM_SQ_EX_301 SPACE FRAME ELEMENT', IE PRINT *, 'BAD REFERENCE NODE ', NODE_3, ' AT', XYZ_3 PRINT *, 'TRY REVERSING ELEMENT CONNECTIVITY' PRINT *, 'NO LOCAL X-ROTATION USED' N_WARN = N_WARN + 1 SIN_L = 0.d0 ; COS_L = 1.d0 ELSE SIN_L = XYZ_3S (3) / QS !b COS_L = - CY * XYZ_3S (1) / QS !b END IF ! BAD DATA ROT_3 (2, 1) = -CY * COS_L !b ROT_3 (3, 1) = CY * SIN_L !b ROT_3 (2, 3) = SIN_L !b ROT_3 (3, 3) = COS_L !b END IF ELSE ! A GENERAL BEAM !************************************************************* !*** ROTATION ABOUT THE MEMBER X-AXIS IS NOT ACCOUNTED FOR; !*** THAT IS MEMBER IS ASSUMED TO BE SITTING IN GLOBAL Y AND !*** OWN LOCAL X-AXIS (CORRECT FOR CIRCULAR SECTIONS) !************************************************************* ROT_3 (1, 1) = CX ! Weaver Eq. 1-25 ROT_3 (1, 2) = CY ROT_3 (1, 3) = CZ ROT_3 (2, 1) = -CX * CY / Q !b C21 ROT_3 (2, 2) = Q !b C22 ROT_3 (2, 3) = -CY * CZ / Q !b C23 ROT_3 (3, 1) = -CZ / Q !b C31 ROT_3 (3, 2) = 0.d0 ROT_3 (3, 3) = CX / Q !b C33 ! IS THIRD NODE USED FOR ROTATION ABOUT MEMBER LENGTH ? IF ( NODE_3 > 0 ) THEN ! LOCAL X ROTATION OF NON VERTICAL BEAM XYZ_3G = MATMUL (ROT_3, XYZ_3S) IF ( DEBUG_EL_SQ ) PRINT *, 'XYZ_3G ', XYZ_3G QS = SQRT ( XYZ_3G (2) **2 + XYZ_3G (3) **2 ) IF ( QS == 0.d0 ) THEN ! BAD DATA PRINT *, 'WARNING, ELEM_SQ_EX_301 SPACE FRAME ELEMENT', IE PRINT *, 'BAD REFERENCE NODE ', NODE_3, ' AT', XYZ_3 PRINT *, 'TRY REVERSING ELEMENT CONNECTIVITY' PRINT *, 'NO LOCAL X-ROTATION USED' N_WARN = N_WARN + 1 SIN_L = 0.d0 ; COS_L = 1.d0 ELSE SIN_L = XYZ_3G (3) / QS COS_L = XYZ_3G (2) / QS END IF ! BAD DATA ! UPDATE ROT_3 FOR ADDITIONAL LOCAL X-ROTATION, Eq 1-29' ROT_3 (2, 1) = (-CX * CY * COS_L - CZ * SIN_L) / Q !b ROT_3 (2, 2) = Q * COS_L !b ROT_3 (2, 3) = (-CY * CZ * COS_L + CX * SIN_L) / Q !b ROT_3 (3, 1) = ( CX * CY * SIN_L - CZ * COS_L) / Q !b ROT_3 (3, 2) = -Q * SIN_L !b ROT_3 (3, 3) = ( CY * CZ * SIN_L + CX * COS_L) / Q !b END IF ! LOCAL X_ROTATION ENDIF IF ( DEBUG_EL_SQ .AND. IE >= 1 ) THEN WRITE (6,*) '*** VECTOR TRANSFORMATION MATRIX ***' CALL RPRINT (ROT_3, 3, 3, 0) END IF !--> CREATE FULL 12*12 ROTATIONAL TRANSFORMATION FROM LOCAL 3*3 DO I = 1, 3 I1 = I I2 = I + 3 I3 = I + 6 I4 = I + 9 DO J = 1, 3 J1 = J J2 = J + 3 J3 = J + 6 J4 = J + 9 ROT_12 (I1, J1) = ROT_3 (I, J) ROT_12 (I2, J2) = ROT_3 (I, J) ROT_12 (I3, J3) = ROT_3 (I, J) ROT_12 (I4, J4) = ROT_3 (I, J) END DO END DO !b IF ( DEBUG_EL_SQ .AND. IE >= 1) WRITE (6,*) & !b '*** STRUCTURE TRANSFORMATION MATRIX ***' !b IF ( DEBUG_EL_SQ .AND. IE >= 1) & !b CALL RPRINT (ROT_12, N_EL_FRE, N_EL_FRE, 0) !--> AXIAL FORCE CONTRIBUTIONS S1,S7 S_LOCAL (1, 1) = ELASTIC * AREA / BAR_L S_LOCAL (1, 7) = -ELASTIC * AREA / BAR_L S_LOCAL (7, 1) = -ELASTIC * AREA / BAR_L S_LOCAL (7, 7) = ELASTIC * AREA / BAR_L !--> TORQUE CONTRIBUTIONS S4,S10 S_LOCAL (4, 4) = SHEAR * IX /BAR_L S_LOCAL (4, 10) = -SHEAR * IX /BAR_L S_LOCAL (10, 4) = -SHEAR * IX /BAR_L S_LOCAL (10, 10) = SHEAR * IX /BAR_L !--> X-Y PLANE LOAD AND MOMENT S2,S6,S8,S12 T (1, 1) = 12.d0 * ELASTIC * BAR_L / BAR_L4 T (2, 1) = 6.d0 * ELASTIC / BAR_L2 T (3, 1) = -12.d0 * ELASTIC * BAR_L / BAR_L4 T (4, 1) = 6.d0 * ELASTIC / BAR_L2 T (2, 2) = 4.d0 * ELASTIC / BAR_L T (3, 2) = -6.d0 * ELASTIC / BAR_L2 T (4, 2) = 2.d0 * ELASTIC / BAR_L T (3, 3) = 12.d0 * ELASTIC * BAR_L / BAR_L4 T (4, 3) = -6.d0 * ELASTIC / BAR_L2 T (4, 4) = 4.d0 * ELASTIC / BAR_L S_LOCAL (2, 2) = T (1, 1) * IZ S_LOCAL (6, 2) = T (2, 1) * IZ S_LOCAL (8, 2) = T (3, 1) * IZ S_LOCAL (12, 2) = T (4, 1) * IZ S_LOCAL (6, 6) = T (2, 2) * IZ S_LOCAL (8, 6) = T (3, 2) * IZ S_LOCAL (12, 6) = T (4, 2) * IZ S_LOCAL (8, 8) = T (3, 3) * IZ S_LOCAL (12, 8) = T (4, 3) * IZ S_LOCAL (12, 12) = T (4, 4) * IZ !*** SYMMETRIC PART S_LOCAL (2, 6) = S_LOCAL (6, 2) S_LOCAL (2, 8) = S_LOCAL (8, 2) S_LOCAL (2, 12) = S_LOCAL (12, 2) S_LOCAL (6, 8) = S_LOCAL (8, 6) S_LOCAL (6, 12) = S_LOCAL (12, 6) S_LOCAL (8, 12) = S_LOCAL (12, 8) !--> X-Z PLANE LOAD AND MOMENT S3,S5,S9,S11 S_LOCAL (3, 3) = T (1, 1) * IY S_LOCAL (5, 3) = -T (2, 1) * IY S_LOCAL (9, 3) = T (3, 1) * IY ! S_LOCAL (9, 3) = -T (3, 1) * IY S_LOCAL (11, 3) = -T (4, 1) * IY S_LOCAL (5, 5) = T (2, 2) * IY S_LOCAL (9, 5) = -T (3, 2) * IY S_LOCAL (11, 5) = T (4, 2) * IY ! S_LOCAL (11, 5) = -T (4, 2) * IY S_LOCAL (9, 9) = T (3, 3) * IY S_LOCAL (11, 9) = -T (4, 3) * IY S_LOCAL (11, 11) = T (4, 4) * IY !*** SYMMETRIC PART S_LOCAL (3, 5) = S_LOCAL (5, 3) S_LOCAL (3, 9) = S_LOCAL (9, 3) S_LOCAL (3, 11) = S_LOCAL (11, 3) S_LOCAL (5, 9) = S_LOCAL (9, 5) S_LOCAL (5, 11) = S_LOCAL (11, 5) S_LOCAL (9, 11) = S_LOCAL (11, 9) !*** LOCAL WEIGHT EFFECTS *** !(xxx new) G_LOCAL = MATMUL ( ROT_3, G_GLOBAL ) !*** CALCULATE LOCAL MEMBER FORCE MATRIX (C_LOCAL) FOR A ! -----^ LINEARLY VARYING LINE LOAD ! ------- : IN LOCAL X_Y PLANE IN THE ! ^---- : WPL_R Y-DIRECTION ! WPL_L: : ! 1 *------(e)-------*2 ----> X_local C_LOCAL(1) = 0.d0 C_LOCAL(2) = (7.d0 * WPL_L + 3.d0 * WPL_R) * BAR_L / 20.d0 C_LOCAL(3) = 0.d0 C_LOCAL(4) = 0.d0 C_LOCAL(5) = 0.d0 C_LOCAL(6) = BAR_L2 * WPL_L / 20.d0 + BAR_L2 * WPL_R / 30.d0 C_LOCAL(7) = 0.d0 C_LOCAL(8) = (3.d0 * BAR_L * WPL_L + 7.d0 * BAR_L * WPL_R) / 20.d0 C_LOCAL(9) = 0.d0 C_LOCAL(10) = 0.d0 C_LOCAL(11) = 0.d0 C_LOCAL(12) = -BAR_L2 * WPL_L / 30.d0 - BAR_L2 * WPL_R / 20.d0 !*** TRANSFORM LOCAL ELEMENT STIFFNESS MATRIX TO GLOBAL *** S = MATMUL (TRANSPOSE (ROT_12), MATMUL (S_LOCAL, ROT_12)) !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b WRITE (6,*) '*** LOCAL STIFFNESS MATRIX ***' !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b CALL RPRINT (S_LOCAL, N_EL_FRE, N_EL_FRE,1) IF ( DEBUG_EL_SQ .AND. IE >= 1) & WRITE (6,*) '*** GLOBAL STIFFNESS MATRIX ***' IF ( DEBUG_EL_SQ .AND. IE >= 1) & CALL RPRINT (s, N_EL_FRE, N_EL_FRE,1) !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b WRITE (6, *) '*** LOCAL LOAD VECTOR ***' !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b CALL RPRINT (C_LOCAL, N_EL_FRE, 1, 1) !*** TRANSFORM LOCAL ELEMENT LOAD VECTOR TO GLOBAL *** C = MATMUL (TRANSPOSE (ROT_12), C_LOCAL) !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b WRITE (6,*) '*** GLOBAL LOAD VECTOR ***' !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b CALL RPRINT (c, N_EL_FRE, 1,0) !*** TRANSFORM GLOBAL DEFLECTION TO LOCAL D_LOCAL = MATMUL ( ROT_12, D ) !b IF ( DEBUG_EL_SQ .AND. IE == 1) & !b WRITE (6, *) 'D_GLOBAL ' !b IF ( DEBUG_EL_SQ .AND. IE == 1) & !b CALL RPRINT (D, 1, N_EL_FRE,1) !b IF ( DEBUG_EL_SQ .AND. IE == 1) & !b WRITE (6, *) 'D_LOCAL ' !b IF ( DEBUG_EL_SQ .AND. IE == 1) & !b CALL RPRINT (D_LOCAL, 1, N_EL_FRE,1) !*** CALCULATE LOCAL REACTION FORCE R_LOCAL = MATMUL(S_LOCAL, D_LOCAL) - C_LOCAL !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b WRITE (6, *) 'R_LOCAL ' !b IF ( DEBUG_EL_SQ .AND. IE > 0) & !b CALL RPRINT (R_LOCAL, 1, N_EL_FRE,1) FORCE_REACT = (R_LOCAL (7) - R_LOCAL (1)) / 2.d0 !b print *,'FORCE_REACT = ', FORCE_REACT ! FORCE_REACT = (R_LOCAL (1) - R_LOCAL (7)) / 2.d0 !b FORCE_REACT = FORCE ! force axial load on all iterationa ! IF ( ABS (FORCE_REACT) > EPSILON (FORCE_REACT) ) THEN ! ACTIVE IF ( LARGE_DISP ) THEN ! ACTIVE WRITE (6, *) '*** GEOMETRIC STIFFNESS ACTIVE ***' WRITE (6, *) 'AXIAL FORCE = ', FORCE_REACT IF ( FORCE_REACT < 0.d0 ) THEN WRITE (N_BUG, *) 'WARNING: COMPRESSIVE AXIAL FORCE PRESENT' N_WARN = N_WARN + 1 END IF ! IN COMPRESSION !b IF ( DEBUG_EL_SQ .AND. IE == 1) & !b WRITE (6,*) '*** BEAM STIFFNESS MATRIX ***' !b IF ( DEBUG_EL_SQ .AND. IE == 1) & !b CALL RPRINT (S_LOCAL, N_EL_FRE, N_EL_FRE,1) SG_LOCAL = 0.d0 ! initialize (xxx new) !*** GEOMETRIC STIFFNESS TG (1, 1) = 6.d0 / 5.d0 TG (2, 1) = BAR_L / 10.d0 TG (3, 1) = -6.d0 / 5.d0 TG (4, 1) = BAR_L / 10.d0 TG (1, 2) = BAR_L / 10.d0 TG (2, 2) = 2.d0 * BAR_L2 / 15.d0 TG (3, 2) = -BAR_L / 10.d0 TG (4, 2) = -BAR_L2 / 30.d0 TG (1, 3) = -6.d0 / 5.d0 TG (2, 3) = -BAR_L / 10.d0 TG (3, 3) = 6.d0 / 5.d0 TG (4, 3) = -BAR_L / 10.d0 TG (1, 4) = BAR_L / 10.d0 TG (2, 4) = -BAR_L2 / 30.d0 TG (3, 4) = -BAR_L / 10.d0 TG (4, 4) = 2.d0 * BAR_L2 / 15.d0 !*** CALCULATE GEOMETRICAL STIFFNESS MATRIX TG = TG * FORCE_REACT / BAR_L ! SG_LOCAL = SG_LOCAL * FORCE_REACT / BAR_L ! X-AXIAL FORCE ONLY (EQ 15.21 Przemieniecki) IF ( AREA > 0.d0 ) THEN ! ADD GEOMETRIC PART SG_LOCAL (2, 2) = FORCE_REACT / BAR_L ! local y coupling SG_LOCAL (8, 2) = -FORCE_REACT / BAR_L ! local y coupling SG_LOCAL (2, 8) = -FORCE_REACT / BAR_L ! local y coupling SG_LOCAL (8, 8) = FORCE_REACT / BAR_L ! local y coupling SG_LOCAL (3, 3) = FORCE_REACT / BAR_L ! local z coupling SG_LOCAL (9, 3) = -FORCE_REACT / BAR_L ! local z coupling SG_LOCAL (3, 9) = -FORCE_REACT / BAR_L ! local z coupling SG_LOCAL (9, 9) = FORCE_REACT / BAR_L ! local z coupling END IF ! AXIAL COUPLING !--> X-Y PLANE LOAD AND MOMENT S2,S6,S8,S12 IF ( IZ > 0.d0 ) THEN ! BENDING COUPLING SG_LOCAL (2, 2) = TG (1, 1) + SG_LOCAL (2, 2) SG_LOCAL (6, 2) = TG (2, 1) SG_LOCAL (8, 2) = TG (3, 1) + SG_LOCAL (8, 2) SG_LOCAL (12, 2) = TG (4, 1) SG_LOCAL (6, 6) = TG (2, 2) SG_LOCAL (8, 6) = TG (3, 2) SG_LOCAL (12, 6) = TG (4, 2) SG_LOCAL (8, 8) = TG (3, 3) + SG_LOCAL (8, 8) SG_LOCAL (12, 8) = TG (4, 3) SG_LOCAL (12, 12) = TG (4, 4) !*** SYMMETRIC PART SG_LOCAL (2, 6) = SG_LOCAL (6, 2) SG_LOCAL (2, 8) = SG_LOCAL (8, 2) SG_LOCAL (2, 12) = SG_LOCAL (12, 2) SG_LOCAL (6, 8) = SG_LOCAL (8, 6) SG_LOCAL (6, 12) = SG_LOCAL (12, 6) SG_LOCAL (8, 12) = SG_LOCAL (12, 8) END IF ! BENDING COUPLING !--> X-Z PLANE LOAD AND MOMENT S3,S5,S9,S11 IF ( IY > 0.d0 ) THEN ! BENDING COUPLING SG_LOCAL (3, 3) = TG (1, 1) + SG_LOCAL (3, 3) SG_LOCAL (5, 3) = -TG (2, 1) SG_LOCAL (9, 3) = TG (3, 1) + SG_LOCAL (9, 3) SG_LOCAL (11, 3) = -TG (4, 1) SG_LOCAL (5, 5) = TG (2, 2) SG_LOCAL (9, 5) = -TG (3, 2) SG_LOCAL (11, 5) = TG (4, 2) SG_LOCAL (9, 9) = TG (3, 3) + SG_LOCAL (9, 9) SG_LOCAL (11, 9) = -TG (4, 3) SG_LOCAL (11, 11) = TG (4, 4) !*** SYMMETRIC PART SG_LOCAL (3, 5) = SG_LOCAL (5, 3) SG_LOCAL (3, 9) = SG_LOCAL (9, 3) SG_LOCAL (3, 11) = SG_LOCAL (11, 3) SG_LOCAL (5, 9) = SG_LOCAL (9, 5) SG_LOCAL (5, 11) = SG_LOCAL (11, 5) SG_LOCAL (9, 11) = SG_LOCAL (11, 9) END IF ! BENDING COUPLING IF ( DEBUG_EL_SQ .AND. IE == 1) WRITE (6,*) & '*** GEOMETRIC STIFFNESS MATRIX ***' IF ( DEBUG_EL_SQ .AND. IE == 1) & CALL RPRINT (SG_LOCAL, N_EL_FRE, N_EL_FRE, 1) ! *** MOVE GEOMETRIC TERMS TO RHS *** C = C - MATMUL (TRANSPOSE (ROT_12), MATMUL (SG_LOCAL, D_LOCAL)) !!*** COMBINE LOCAL STIFFNESS MATRIX ! S_LOCAL = S_LOCAL + SG_LOCAL ELSE ! NO GEOMETRIC STIFFNESS IF ( DEBUG_EL_SQ ) WRITE (6, *) & '*** GEOMETRIC STIFFNESS NOT ACTIVE ***' END IF ! INCLUDE GEOMETRIC EFFECTS ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_301 SUBROUTINE POST_PROCESS_ELEM_EX_301 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_301 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER STOP 'ERROR: NO SOURCE AT POST_PROCESS_ELEM_EX_301' END SUBROUTINE POST_PROCESS_ELEM_EX_301 ! ============= End Files for EXAMPLE number 301 ============= ! ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| !============= Begin Files for EXAMPLE number 302 ============= SUBROUTINE DESCRIBE_EXAMPLE_302 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *, '*** DESCRIPTIONS OF EXAMPLE 302 (SUBSET OF 209) ***' PRINT *,'ANISOTROPIC POISSON EQUATION IN 3-D' PRINT *,'VIA NUMERICALLY INTEGRATED ELEMENTS' PRINT *,' Standard Element Properties assumed: ' PRINT *,' 1-D problem, K_xx, Q, Thickness' PRINT *,' 2-D problem, K_xx, K_yy, K_xy, Q, Thickness' PRINT *,' 3-D problem, K_xx, K_yy, K_zz, K_xy, K_xz, K_yz, Q' PRINT *,' Convection Element Properties assumed:' PRINT *,' Point: h, T_inf, Area' PRINT *,' Line: h, T_inf, Thickness' PRINT *,' Face: h, T_inf' END SUBROUTINE DESCRIBE_EXAMPLE_302 ! ============= End Files for EXAMPLE number 302 ============= !============= Begin Files for EXAMPLE number 303 ============= SUBROUTINE DESCRIBE_EXAMPLE_303 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! LIST A DESCRIPTION OF THE EXAMPLE APPLICATION,ITS ! TYPICAL DATA AND ANY EXACT SOLUTIONS AVAILABLE ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE PRINT *,'*** DESCRIPTIONS OF EXAMPLE 303 ***' PRINT *,'SOLID STRESS ANALYSIS, NON-ISOPARAMETRIC' PRINT *,'DISPLACEMENT COMPONENT ORDER: X, Y, Z' PRINT *,'STRESS COMPONENTS: XX, YY, XY, ZZ, XZ, YZ, VonMise' PRINT *,'PROPERTIES: 1-ELASTIC MODULUS, 2-POISSON RATIO' PRINT *,'OPTIONAL: 3-YIELD STRESS, 3 @ BODY FORCE VECTOR' PRINT *,'' PRINT *,'DATA_SET 01 pending' PRINT *,'Rectangular beam with pure couple, 1/4 symmetry' PRINT *,'Two H8 elements, gives exact disp and stresses' PRINT *,'' PRINT *,'DATA_SET 02' PRINT *,'Axial bar with end load, 1/4 symmetry' PRINT *,'Two H8 elements, gives exact disp and stresses' PRINT *,'' PRINT *,'DATA_SET 03 pending' PRINT *,'Axial bar hanging with its weight , 1/4 symmetry' PRINT *,'Two H8 elements, gives exact disp and stresses' END SUBROUTINE DESCRIBE_EXAMPLE_303 SUBROUTINE ELEM_SQ_EX_303 (E, H_INTG, PRT_L_PT, PRT_MAT, & L_PT_PROP, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Geometric_Properties Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions Use Select_Source ! for SELECT_EXACT_* IMPLICIT NONE INTEGER, INTENT(IN) :: IE REAL(DP), INTENT(INOUT) :: E (N_R_B, N_R_B) REAL(DP), INTENT(INOUT) :: H_INTG (LT_N) !b make optional !uu ! OPTIONAL PROPERTY VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays REAL(DP) :: AJ (N_SPACE, N_SPACE), XYZ (N_SPACE), & AJ_INV (N_SPACE, N_SPACE), BODY (N_SPACE) REAL(DP) :: STRAIN_0 (N_R_B), STRAIN (N_R_B + 2), & STRESS (N_R_B + 2) REAL(DP) :: B (N_R_B, LT_FREE), EB (N_R_B, LT_FREE), & DGH (N_SPACE, LT_N), DGV (N_SPACE, LT_FREE) ! VARIABLES: See file NOTATION.f ! .............................................................. ! *** ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! ............................................................ ! SOLID STRESS ANALYSIS, NON-ISOPARAMETRIC ! STRESS COMPONENT ORDER: XX, YY, XY, ZZ, XZ, YZ, SO N_R_B = 6 INTEGER :: IP, J, K, ROW ! loops REAL(DP) :: DET, DET_WT ! volume CALL STORE_FLUX_POINT_COUNT ! Save LT_QP for poswt-processing ! FORM THE CONSTITUTIVE MATRIX (OR GET_APPLICATION_E_MATRIX) ! PROPERTIES: 1-YOUNG'S MODULUS, 2-POISSON'S RATIO, AND ! 3-YIELD STRESS, OPTIONAL: 3 @ BODY FORCE VECTOR CALL E_SOLID_STRESS (E) DO IP = 1, LT_QP ! NUMERICAL INTEGRATION LOOP G = GET_G_AT_QP (IP) ! GEOMETRY INTERPOLATIONS GEOMETRY = COORD (1:LT_GEOM,:) ! GEOMETRY NODES XYZ = MATMUL ( G, GEOMETRY ) ! COORDINATES OF POINT DLG = GET_DLG_AT_QP (IP) ! GEOMETRIC DERIVATIVES AJ = GEOMETRIC_JACOBIAN () ! JACOBIAN CALL INVERT_3BY3 (AJ, AJ_INV, DET)! INVERSE, DET DET_WT = DET * WT (IP) H = GET_H_AT_QP (IP) ! SCALAR INTERPOLATIONS DLH = GET_DLH_AT_QP (IP) ! SCALAR DERIVATIVES DGH = MATMUL ( AJ_INV, DLH ) ! PHYSICAL DERIVATIVES !---> FORM STRAIN DISPLACEMENT, B (OR GET_APPLICATION_B_MATRIX) CALL ELASTIC_B_SOLID (DGH, B) ! SAVE PT, CONSTITUTIVE & STRAIN_DISP FOR POST_PROCESS & SCP CALL STORE_FLUX_POINT_DATA (XYZ, E, B) ! EVALUATE ELEMENT STIFFNESS MATRIX S = S + DET_WT * MATMUL (TRANSPOSE(B), MATMUL (E, B)) ! BODY FORCE PER UNIT VOLUME, CONSTANTS IN KEYWORD body_force ? IF ( .NOT. FORCE_BODY ) THEN ! Check element values in data IF ( EL_REAL >= 6 ) THEN ! Element body force given BODY_FORCE (1) = GET_REAL_LP (4) BODY_FORCE (2) = GET_REAL_LP (5) BODY_FORCE (3) = GET_REAL_LP (6) ELSE ; CYCLE ! To next IP because of no body force END IF END IF ! or set up properties for body force ! FORM BODY FORCE VECTOR DO J = 1, LT_N ! LOOP OVER NODES DO K = 1, N_G_DOF ! DOF PER NODE ROW = N_G_DOF * (J - 1) + K ! Nodal force component C (ROW) = C (ROW) + H (J) * BODY_FORCE (K) * DET_WT END DO ! nodal dof END DO ! nodes END DO ! Over quadrature points ! ............................................................ ! *** END ELEM_SQ_MATRIX PROBLEM DEPENDENT STATEMENTS *** ! ............................................................ ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) END SUBROUTINE ELEM_SQ_EX_303 SUBROUTINE POST_PROCESS_ELEM_EX_303 (PRT_L_PT, PRT_MAT, & L_PT_PROP, ITER, IE) ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ELEMENT LEVEL POST-SOLUTION CALCULATIONS, FROM ELEM_POST_EX_303 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * Use System_Constants ! For EXAMPLE Use Elem_Type_Data ! for: Use Sys_Properties_Data ! for FLT_MISC, MISC_FIX Use Interface_Header ! for functions IMPLICIT NONE INTEGER, INTENT(IN) :: ITER, IE ! ITERATION, ELEMENT NUMBER ! OPTIONAL PROPERTY AND SOLUTION VALUES REAL(DP), INTENT(IN) :: PRT_L_PT (LT_N, N_NP_FLO), & PRT_MAT (MISC_FL) INTEGER, INTENT(IN) :: L_PT_PROP (N_NP_FIX) ! Automatic Arrays (Usually used.) REAL(DP) :: B (N_R_B, LT_FREE), DGH (N_SPACE, LT_N), & DGV (N_SPACE, LT_FREE), & E (N_R_B, N_R_B), EB (N_R_B, LT_FREE), & STRAIN (N_R_B + 2), STRAIN_0 (N_R_B), & STRESS (N_R_B + 2), BODY (N_SPACE) ! OPTIONAL FOR NUMERICAL INTEGRATION REAL(DP) :: AJ (N_SPACE, N_SPACE), AJ_INV (N_SPACE, N_SPACE), & H_INTG (LT_N), XYZ (N_SPACE) ! VARIABLES: See file NOTATION.f ! .................................................... ! *** POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS FOLLOW *** ! .................................................... ! SOLID STRESS ANALYSIS ! STRESS COMPONENT ORDER: XX, YY, XY, ZZ, XZ, YZ, SO N_R_B = 6 ! PROPERTIES: 1-YOUNG'S MODULUS, 2-POISSON'S RATIO, AND ! 3-YIELD STRESS, OPTIONAL: 3 @ BODY FORCE VECTOR INTEGER :: J, N_IP ! LOOPS REAL(DP), SAVE :: YIELD ! FAILURE DATA IF ( IE == 1 ) THEN ! PRINT TITLES & INITIALIZE STRAIN = 0.d0 ; STRAIN_0 = 0.d0 ! INITIALIZE ALL OF "STRAIN" IF ( EL_REAL > 2 ) THEN ! INITIALIZE YIELD STRESS YIELD = GET_REAL_LP (3) ELSE ; YIELD = HUGE (1.d0) ; END IF ! YIELD DATA WRITE (6, 50) ; 50 FORMAT ( /, & '*** STRESSES AT INTEGRATION POINTS ***', /, & ' COORDINATES STRESSES', /, & 'PT X Y Z XX, YY, XY',/, & 'PT X Y Z ZZ, XZ, YZ',/, & 'PT X Y Z Von Mises Effective') END IF ! NEW HEADINGS WRITE (6, * ) ' ELEMENT NUMBER ', IE CALL READ_FLUX_POINT_COUNT (N_IP) ! NUMBER OF QUADRATURE POINTS DO J = 1, N_IP ! AT QUADRATURE POINTS CALL READ_FLUX_POINT_DATA (XYZ, E, B) ! PT, PROP, STRAIN_DISP ! MECHANICAL STRAINS & STRESSES STRAIN (1:N_R_B) = MATMUL (B, D) ! STRAINS AT THE POINT STRESS (1:N_R_B) = MATMUL (E, STRAIN (1:N_R_B)) ! STRESSES ! VON_MISES FAILURE CRITERION (EFFECTIVE STRESS, ADD TO END) CALL VON_MISES_STRESS (STRESS(1:N_R_B), 0.0, 5, STRESS (7), N_R_B) IF ( STRESS (7) >= YIELD ) PRINT *, & 'WARNING: FAILURE CRITERION EXCEEDED IN ELEMENT =', IE ! LIST STRESSES AND FAILURE CRITERION AT POINT WRITE (6, 52) J, XYZ (1:3), STRESS (1:3) WRITE (6, 52) J, XYZ (1:3), STRESS (4:6) WRITE (6, 52) J, XYZ (1:3), STRESS ( 7 ) 52 FORMAT ( I2, 3(1PE10.2), 3(1PE10.2) ) END DO ! AT QUADRATURE POINTS ! .................................................... ! *** END 303.POST_PROCESS_ELEM PROBLEM DEPENDENT STATEMENTS *** ! .................................................... ! suppress compiler warnings (touch is never true) IF ( TOUCH ) CALL TOUCH_UNUSED_ITEMS_1 (AJ, AJ_INV, B, BODY, DGH, & DGV, E, EB, G, H_INTG, IE, L_PT_PROP, PRT_L_PT, & PRT_MAT, STRAIN, STRAIN_0, STRESS, XYZ) IF ( TOUCH ) PRINT *, ITER END SUBROUTINE POST_PROCESS_ELEM_EX_303 ! ============= End Files for EXAMPLE number 303 =============