OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_move_funct.F File Reference
#include "implicit_f.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_move_funct (npc, pld, nfunct, table, ntable, funcrypt, unitab, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_move_funct()

subroutine hm_read_move_funct ( integer, dimension(*) npc,
pld,
integer nfunct,
type(ttable), dimension(*) table,
integer ntable,
integer, dimension(*) funcrypt,
type(unit_type_), intent(in) unitab,
type(submodel_data), dimension(nsubmod), intent(in) lsubmodel )

Definition at line 37 of file hm_read_move_funct.F.

38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE unitab_mod
42 USE table_mod
43 USE submodel_mod
44 USE hm_option_read_mod
45 USE names_and_titles_mod , ONLY : nchartitle
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50C-----------------------------------------------
51C D u m m y A r g u m e n t s
52C-----------------------------------------------
53 INTEGER NFUNCT, NTABLE
54 INTEGER NPC(*),FUNCRYPT(*)
55 my_real pld(*)
56 TYPE(TTABLE) TABLE(*)
57 TYPE(UNIT_TYPE_), INTENT(IN) :: UNITAB
58 TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "units_c.inc"
63C-----------------------------------------------
64C L o c a l V a r i a b l e s
65C-----------------------------------------------
66 INTEGER I,J,N,ID,IFIX_TMP,CPT
67 my_real scx,scy,shx,shy
68 my_real, DIMENSION(:),ALLOCATABLE :: pld_tmp
69 INTEGER :: NMOVE_FUNCT
70 LOGICAL :: IS_AVAILABLE
71 CHARACTER(LEN=NCHARTITLE) :: TITR
72! *************************** !
73! * Count /MOVE_FUNCT cards * !
74! *************************** !
75 CALL hm_option_count('/MOVE_FUNCT', nmove_funct)
76
77 IF (nmove_funct > 0) THEN
78 WRITE (iout, 2000)
79 CALL hm_option_start('/MOVE_FUNCT')
80 DO i = 1, nmove_funct
81 CALL hm_option_read_key(lsubmodel, option_id = id, option_titr = titr)
82 CALL hm_get_floatv('Ascalex', scx, is_available, lsubmodel, unitab)
83 CALL hm_get_floatv('Fscaley', scy, is_available, lsubmodel, unitab)
84 CALL hm_get_floatv('Ashiftx', shx, is_available, lsubmodel, unitab)
85 CALL hm_get_floatv('Fshifty', shy, is_available, lsubmodel, unitab)
86
87 IF (scx == zero) scx = one
88 IF (scy == zero) scy = one
89 DO n = 1,nfunct
90 IF (npc(nfunct+1+n) == id) THEN
91 IF (funcrypt(n) == 0) THEN
92 WRITE (iout,2100) id,scx,scy,shx,shy
93 ELSE
94 WRITE (iout,2200) id,scx,scy,shx,shy
95 ENDIF
96 IF(scx >= zero) THEN
97 DO j = npc(n),npc(n+1)-1,2
98 pld(j) = pld(j) *scx
99 pld(j+1) = pld(j+1)*scy
100 pld(j) = pld(j) +shx
101 pld(j+1) = pld(j+1)+shy
102 IF (funcrypt(n) == 0) WRITE(iout,'(8X,1PG20.13,2X,1G20.13)')pld(j),pld(j+1)
103 ENDDO
104 ELSEIF(scx < zero) THEN
105 ALLOCATE(pld_tmp(npc(n+1)))
106 cpt = 1
107 DO j = npc(n),npc(n+1)-1,2
108 pld_tmp(j) = pld(npc(n+1)-1-cpt) *scx
109 pld_tmp(j+1) = pld(npc(n+1)-cpt)*scy
110 pld_tmp(j) = pld_tmp(j) +shx
111 pld_tmp(j+1) = pld_tmp(j+1)+shy
112 cpt = cpt + 2
113 ENDDO
114 DO j = npc(n),npc(n+1)-1,2
115 pld(j) = pld_tmp(j)
116 pld(j+1) = pld_tmp(j+1)
117 IF (funcrypt(n) == 0) WRITE(iout,'(8X,1PG20.13,2X,1G20.13)')pld(j),pld(j+1)
118 ENDDO
119 IF(ALLOCATED(pld_tmp)) DEALLOCATE(pld_tmp)
120 ENDIF
121 EXIT
122 ENDIF
123 ENDDO
124 DO n = 1,ntable
125 IF (table(n)%NOTABLE == id) THEN
126 IF(scx >= zero) THEN
127 DO j = 1,SIZE(table(n)%X(1)%VALUES)
128 table(n)%X(1)%VALUES(j)= table(n)%X(1)%VALUES(j) *scx
129 table(n)%Y%VALUES(j) = table(n)%Y%VALUES(j) *scy
130 table(n)%X(1)%VALUES(j)= table(n)%X(1)%VALUES(j) +shx
131 table(n)%Y%VALUES(j) = table(n)%Y%VALUES(j) +shy
132 ENDDO
133 ELSE
134 ALLOCATE(pld_tmp(SIZE(table(n)%X(1)%VALUES)*2))
135 cpt = 1
136 DO j = 1,2*SIZE(table(n)%X(1)%VALUES),2
137 pld_tmp(j) = table(n)%X(1)%VALUES(cpt) *scx +shx
138 pld_tmp(j+1) = table(n)%Y%VALUES(cpt) *scy +shy
139 cpt = cpt + 1
140 ENDDO
141
142 cpt = 1
143 DO j = 1,SIZE(table(n)%X(1)%VALUES)
144 table(n)%X(1)%VALUES(j) = pld_tmp(2*SIZE(table(n)%X(1)%VALUES)-cpt)
145 table(n)%Y%VALUES(j) = pld_tmp(2*SIZE(table(n)%X(1)%VALUES)-cpt+1)
146 cpt = cpt + 2
147 ENDDO
148
149 IF(ALLOCATED(pld_tmp)) DEALLOCATE(pld_tmp)
150 ENDIF
151 EXIT
152 ENDIF
153 ENDDO
154 ENDDO
155 ENDIF
156C
157 RETURN
158C-----------------------------------------------------------------
1592000 FORMAT(//
160 . ' FUNCTION TRANSFORMATION '/)
1612100 FORMAT(/
162 . ' LOAD FUNCTION NUMBER. . . . . =',i10/
163 . ' X SCALE = ',e20.13/,
164 . ' Y SCALE = ',e20.13/,
165 . ' X SHIFT = ',e20.13/,
166 . ' Y SHIFT = ',e20.13/,
167 . ' TRANSFORMED VALUES :'/,
168 . ' X Y ')
1692200 FORMAT(/
170 . ' LOAD FUNCTION NUMBER. . . . . =',i10/
171 . ' X SCALE = ',e20.13/,
172 . ' Y SCALE = ',e20.13/,
173 . ' X SHIFT = ',e20.13/,
174 . ' Y SHIFT = ',e20.13/,
175 . ' TRANSFORMED VALUES : CONFIDENTIAL DATA')
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
hm_option_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
id
initmumps id
Definition multiplerhs_example.m:4
hm_option_read_mod
Definition hm_option_read_mod.F:408
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
submodel_mod
Definition submodel_mod.F:712
table_mod
Definition table_mod.F:112
unitab_mod
Definition unitab_mod.F:513