46
47
48
54 USE format_mod , ONLY : fmt_f
55 USE user_id_mod , ONLY : id_limit
56 USE ascii_encoding_mu_letter_mod
57
58
59
60#include "implicit_f.inc"
61
62
63
64 TYPE (UNIT_TYPE_) ::UNITAB
65 TYPE (SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(NSUBMOD)
66
67
68
69#include "scr17_c.inc"
70#include "units_c.inc"
71#include "sysunit.inc"
72
73
74
75 INTEGER I,ID,N,IWRITE,IERR0,,,J,K,IREELM,IREELL,IREELT,
76 . IERR1,ID_OPT(NUNIT0+1),IS_M_STRING,IS_L_STRING,IS_T_STRING
77 my_real unite, bid, m_unit, l_unit, t_unit
78 CHARACTER(LEN=NCHARFIELD) :: KEY
79 CHARACTER(LEN=NCHARFIELD) :: FIELD1,FIELD2,FIELD3
80 CHARACTER*20 FIELD11(NUNIT0+NSUBMOD),
81 . FIELD22(NUNIT0+NSUBMOD),
82 . FIELD33(NUNIT0+NSUBMOD),
83 . KEYMSUB, KEYLSUB, KEYTSUB, KEYMISUB, KEYLISUB, KEYTISUB
84 CHARACTER*40 MESS
85 LOGICAL :: IS_AVAILABLE
86 CHARACTER(LEN=NCHARFIELD) :: UNIT_NAME
87 INTEGER NB_BEGIN,SCHAR,SUB_INDEX,NBUNIT_SUB
88 my_real fac_m_sub,fac_l_sub,fac_t_sub
89
90
91
92 unite = 0
94
95 field11(i) = ' '
96 field22(i) = ' '
97 field33(i) = ' '
98 ENDDO
99
100 is_available = .false.
101
102 WRITE(iout,1000)
103
104 unite = 0
105 unitab%NUNITS = nunit0+
nsubmod+1
106 unitab%NUNIT0 = nunit0
107 ALLOCATE(unitab%UNIT_ID(nunit0+
nsubmod
108 ALLOCATE(unitab%FAC_M (nunit0+
nsubmod+1))
109 ALLOCATE(unitab%FAC_L (nunit0+
nsubmod+1))
110 ALLOCATE(unitab%FAC_T (nunit0+
nsubmod+1))
111
112 fac_m_input = zero
113 fac_l_input = zero
114 fac_t_input = zero
115 fac_m_work = zero
116 fac_l_work = zero
117 fac_t_work = zero
118 fac_m_sub = zero
119 fac_l_sub = zero
120 fac_t_sub = zero
121 field1 = ''
122 field2 = ''
123 field3 = ''
124 m_unit = zero
125 l_unit = zero
126 t_unit = zero
127 ierr1 = 1
129 id_opt(1:nunit0) = 0
130
131
132 IF ( flag_key_m > 1) THEN
133 CALL ancmsg(msgid=575,msgtype=msgerror,anmode=aninfo_blind_1,c1=
'GLOBAL UNIT')
134 ENDIF
135 IF ( flag_key_l > 1) THEN
136 CALL ancmsg(msgid=575,msgtype=msgerror,anmode=aninfo_blind_1,c1=
'GLOBAL UNIT')
137 ENDIF
138 IF ( flag_key_t > 1) THEN
139 CALL ancmsg(msgid=575,msgtype=msgerror,anmode=aninfo_blind_1,c1=
'GLOBAL UNIT')
140 ENDIF
141
142 CALL unit_code(len,keymi,
'MASS' ,fac_m_input, ierr1, 0)
143 CALL unit_code(len,keyli,
'LENGTH',fac_l_input, ierr1, 0)
144 CALL unit_code(len,keyti,
'TIME' ,fac_t_input, ierr1, 0)
145 CALL unit_code(len,keym ,
'MASS' ,fac_m_work , ierr1, 0)
146 IF (fac_m_input == zero) fac_m_input = fac_m_work
147 IF (fac_m_work == zero) fac_m_work = fac_m_input
148 CALL unit_code(len,keyl ,
'LENGTH',fac_l_work , ierr1, 0)
149 IF (fac_l_input == zero) fac_l_input = fac_l_work
150 IF (fac_l_work == zero) fac_l_work = fac_l_input
151 CALL unit_code(len,keyt ,
'TIME' ,fac_t_work , ierr1, 0)
152 IF (fac_t_input == zero) fac_t_input = fac_t_work
153 IF (fac_t_work == zero) fac_t_work = fac_t_input
154
155 fac_mass = fac_m_work
156 fac_length = fac_l_work
157 fac_time = fac_t_work
158
159 unitab%FAC_MASS = fac_m_work
160 unitab%FAC_LENGTH = fac_l_work
161 unitab%FAC_TIME = fac_t_work
162
163 unitab%FAC_M_WORK = fac_m_work
164 unitab%FAC_L_WORK = fac_l_work
165 unitab%FAC_T_WORK = fac_t_work
166 nunits = 1
167 iwrite = 1
168
169 IF (fac_m_input /= fac_m_work .OR.
170 . fac_l_input /= fac_l_work .OR.
171 . fac_t_input /= fac_t_work) THEN
172 CALL ancmsg(msgid=754,msgtype=msgwarning,anmode=aninfo)
173 ENDIF
174
176
177 DO n=1,nunit0
179
180 unit_name = ''
182 IF(unit_name /= 'LENGTH' .AND. unit_name /= 'MASS' .AND. unit_name /= 'TIME') THEN
183 ierr0 = 1
184 nunits = nunits + 1
186
187 CALL hm_get_intv(
'IS_M_STRING',is_m_string,is_available,lsubmodel)
188 IF(is_m_string == 1) THEN
190 ELSE
192 ENDIF
193 CALL hm_get_intv(
'IS_L_STRING',is_l_string,is_available,lsubmodel)
194 IF(is_l_string == 1) THEN
196 ELSE
198 ENDIF
199 CALL hm_get_intv(
'IS_T_STRING',is_t_string,is_available,lsubmodel)
200 IF(is_t_string == 1) THEN
202 ELSE
204 ENDIF
205
206 IF(is_m_string == 1) THEN
207 CALL unit_code(len,field1,
'MASS',unitab%FAC_M(nunits),ierr0,
id)
208 iwrite =
min(ierr0,iwrite)
209 DO k=1,20
210 field11(nunits-1)(k:k) = field1(k:k)
211 ENDDO
212 ELSE
213 unitab%FAC_M(nunits) = m_unit
214 field11(nunits-1) = 'N.A'
215 ENDIF
216 IF(is_l_string == 1) THEN
217 CALL unit_code(len,field2,
'LENGTH',unitab%FAC_L(nunits),ierr0,
id)
218 iwrite =
min(ierr0,iwrite)
219 DO k=1,20
220 field22(nunits-1)(k:k) = field2(k:k)
221 ENDDO
222 ELSE
223 unitab%FAC_L(nunits) = l_unit
224 field22(nunits-1) = 'N.A'
225 ENDIF
226 IF(is_t_string == 1) THEN
227 CALL unit_code(len,field3,
'TIME',unitab%FAC_T(nunits),ierr0,
id)
228 iwrite =
min(ierr0,iwrite)
229 DO k=1,20
230 field33(nunits-1)(k:k) = field3(k:k)
231 ENDDO
232 ELSE
233 unitab%FAC_T(nunits) = t_unit
234 field33(nunits-1) = 'N.A'
235 ENDIF
236 unitab%UNIT_ID(nunits) =
id
237 ENDIF
238
239 ENDDO
240
241 IF (fac_mass == zero) THEN
242 CALL ancmsg(msgid=574,msgtype=msgerror,anmode=aninfo,i1=
id,c1=
'WORK MASS')
243 ENDIF
244 IF (fac_length == zero) THEN
245 CALL ancmsg(msgid=574,msgtype=msgerror,anmode=aninfo,i1=
id,c1=
'WORK LENGTH')
246 ENDIF
247 IF (fac_time == zero) THEN
248 CALL ancmsg(msgid=574,msgtype=msgerror,anmode=aninfo,i1=
id,c1=
'WORK TIME')
249 ENDIF
250
251 unitab%UNIT_ID(1) = 0
252 unitab%FAC_M(1) = fac_mass
253 unitab%FAC_L(1) = fac_length
254 unitab%FAC_T(1) = fac_time
255
256 mess = 'UNITS '
258
261 schar = 20
262 nbunit_sub = 0
263 IF (nb_begin /= 0) THEN
265 DO i=1,nb_begin
267 IF (sub_index /= 0) THEN
268 nbunit_sub = nbunit_sub + 1
269 nunits = nunits + 1
270
271 CALL hm_get_string(
'length_inputunit_code',keylisub,schar,is_available)
272 CALL hm_get_string(
'mass_inputunit_code',keymisub,schar,is_available)
273 CALL hm_get_string(
'time_inputunit_code',keytisub,schar,is_available)
274 CALL hm_get_string(
'length_workunit_code',keylsub,schar,is_available)
275 CALL hm_get_string(
'mass_workunit_code',keymsub,schar,is_available)
276 CALL hm_get_string(
'time_workunit_code',keytsub,schar,is_available)
277
278
279 CALL ascii_encoding_mu_letter(keylisub, keymisub, keytisub, keylsub, keymsub, keytsub)
280
281 DO k=1,20
282 field11(nunits-1)(k:k) = keymisub(k:k)
283 ENDDO
284 DO k=1,20
285 field22(nunits-1)(k:k) = keylisub(k:k)
286 ENDDO
287 DO k=1,20
288 field33(nunits-1)(k:k) = keytisub(k:k)
289 ENDDO
290
291 CALL unit_code(len,keymisub,
'MASS' ,fac_m_sub, ierr1, 0)
292 CALL unit_code(len,keylisub,
'LENGTH',fac_l_sub, ierr1, 0)
293 CALL unit_code(len,keytisub,
'TIME' ,fac_t_sub, ierr1, 0)
294
295 unitab%UNIT_ID(nunits) = id_limit%UNIT + nbunit_sub
296 unitab%FAC_M(nunits) = fac_m_sub
297 unitab%FAC_L(nunits) = fac_l_sub
298 unitab%FAC_T(nunits) = fac_t_sub
299
300 ENDIF
301 ENDDO
302 ENDIF
303 ENDIF
304
305
306 IF (iwrite == 1) THEN
307
308
309
310 ireelm = 0
311 READ(keym,err=100,fmt=fmt_f) unite
312 ireelm = 1
313100 CONTINUE
314 i = 1
315 j = 0
316
318 IF (keym(i:i) /= ' ') EXIT
319 i=i+1
320 ENDDO
321
323 IF (keym(i:i) == ' ') EXIT
324 j=j+1
325 i=i+1
326 ENDDO
327 IF ( ireelm /= 1) THEN
328 DO k=1,j
329 keym(k:k) = keym(k+i-j-1:k+i-j-1)
330 ENDDO
331 ENDIF
332
333
334
335 ireell = 0
336 READ(keyl,err=200,fmt=fmt_f) unite
337 ireell = 1
338200 CONTINUE
339 i = 1
340 j = 0
341
343 IF (keyl(i:i) /= ' ') EXIT
344 i=i+1
345 ENDDO
346
348 IF (keyl(i:i) == ' ') EXIT
349 j=j+1
350 i=i+1
351 ENDDO
352 IF ( ireell /= 1) THEN
353 DO k=1,j
354 keyl(k:k) = keyl(k+i-j-1:k+i-j-1)
355 ENDDO
356 ENDIF
357
358
359
360 ireelt = 0
361 READ(keyt,err=300,fmt=fmt_f) unite
362 ireelt = 1
363300 CONTINUE
364 i = 1
365 j = 0
366
368 IF (keyt(i:i) /= ' ') EXIT
369 i=i+1
370 ENDDO
371
373 IF (keyt(i:i) == ' ') EXIT
374 j=j+1
375 i=i+1
376 ENDDO
377 IF ( ireelt /= 1) THEN
378 DO k=1,j
379 keyt(k:k) = keyt(k+i-j-1:k+i-j-1)
380 ENDDO
381 ENDIF
382
383 IF ( ireelm == 1) THEN
384 keym(1:3) = 'N.A'
385 ENDIF
386
387 IF ( ireell == 1) THEN
388 keyl(1:3) = 'N.A'
389 ENDIF
390
391 IF ( ireelt == 1) THEN
392 keyt(1:3) = 'N.A'
393 ENDIF
394
395 WRITE(iout,1001) keym,keyl,keyt,fac_mass,fac_length,fac_time
396
397
398
399 ireelm = 0
400 READ(keymi,err=700,fmt=fmt_f) unite
401 ireelm = 1
402700 CONTINUE
403 i = 1
404 j = 0
405
407 IF (keymi(i:i) /= ' ') EXIT
408 i=i+1
409 ENDDO
410
412 IF (keymi(i:i) == ' ') EXIT
413 j=j+1
414 i=i+1
415 ENDDO
416 IF ( ireelm /= 1) THEN
417 DO k=1,j
418 keymi(k:k) = keymi(k+i-j-1:k+i-j-1)
419 ENDDO
420 ENDIF
421
422
423
424 ireell = 0
425 READ(keyli,err=800,fmt=fmt_f) unite
426 ireell = 1
427800 CONTINUE
428 i = 1
429 j = 0
430
432 IF (keyli(i:i) /= ' ') EXIT
433 i=i+1
434 ENDDO
435
437 IF (keyli(i:i) == ' ') EXIT
438 j=j+1
439 i=i+1
440 ENDDO
441 IF ( ireell /= 1) THEN
442 DO k=1,j
443 keyli(k:k) = keyli(k+i-j-1:k+i-j-1)
444 ENDDO
445 ENDIF
446
447
448
449 ireelt = 0
450 READ(keyti,err=900,fmt=fmt_f) unite
451 ireelt = 1
452900 CONTINUE
453 i = 1
454 j = 0
455
457 IF (keyti(i:i) /= ' ') EXIT
458 i=i+1
459 ENDDO
460
462 IF (keyti(i:i) == ' ') EXIT
463 j=j+1
464 i=i+1
465 ENDDO
466 IF ( ireelt /= 1) THEN
467 DO k=1,j
468 keyti(k:k) = keyti(k+i-j-1:k+i-j-1)
469 ENDDO
470 ENDIF
471
472 IF ( ireelm == 1) THEN
473 keymi(1:3) = 'N.A'
474 ENDIF
475
476 IF ( ireell == 1) THEN
477 keyli(1:3) = 'N.A'
478 ENDIF
479
480 IF ( ireelt == 1) THEN
481 keyti(1:3) = 'N.A'
482 ENDIF
483
484 WRITE(iout,1003) keymi,keyli,keyti,
485 . fac_m_input,fac_l_input,fac_t_input
486 DO i=2,nunits
487
488 DO k=1,20
489 field1(k:k) = field11(i-1)(k:k)
490 field2(k:k) = field22(i-1)(k:k)
491 field3(k:k) = field33(i-1)(k:k)
492 ENDDO
493
494
495
496 ireelm = 0
497 READ(field1,err=400,fmt=fmt_f) unite
498 ireelm = 1
499400 CONTINUE
500 i1 = 1
501 j = 0
502
503 DO WHILE (i1 <= 20)
504 IF (field1(i1:i1) /= ' ') EXIT
505 i1=i1+1
506 ENDDO
507
508 DO WHILE (i1 <= 20)
509 IF (field1(i1:i1) == ' ') EXIT
510 j=j+1
511 i1=i1+1
512 ENDDO
513 IF ( ireelm /= 1) THEN
514 DO k=1,j
515 field1(k:k) = field1(k+i1-j-1:k+i1-j-1)
516 ENDDO
517 ENDIF
518
519
520
521 ireell = 0
522 READ(field2,err=500,fmt=fmt_f) unite
523 ireell = 1
524500 CONTINUE
525 i1 = 1
526 j = 0
527
528 DO WHILE (i1 <= 20)
529 IF (field2(i1:i1) /= ' ') EXIT
530 i1=i1+1
531 ENDDO
532
533 DO WHILE (i1 <= 20)
534 IF (field2(i1:i1) == ' ') EXIT
535 j=j+1
536 i1=i1+1
537 ENDDO
538 IF ( ireell /= 1) THEN
539 DO k=1,j
540 field2(k:k) = field2(k+i1-j-1:k+i1-j-1)
541 ENDDO
542 ENDIF
543
544
545
546 ireelt = 0
547 READ(field3,err=600,fmt=fmt_f) unite
548 ireelt = 1
549600 CONTINUE
550 i1 = 1
551 j = 0
552
553 DO WHILE (i1 <= 20)
554 IF (field3(i1:i1) /= ' ') EXIT
555 i1=i1+1
556 ENDDO
557
558 DO WHILE (i1 <= 20)
559 IF (field3(i1:i1) == ' ') EXIT
560 j=j+1
561 i1=i1+1
562 ENDDO
563 IF ( ireelt /= 1) THEN
564 DO k=1,j
565 field3(k:k) = field3(k+i1-j-1:k+i1-j-1)
566 ENDDO
567 ENDIF
568
569 IF ( ireelm == 1) THEN
570 field1(1:3) = 'N.A'
571 ENDIF
572
573 IF ( ireell == 1) THEN
574 field2(1:3) = 'N.A'
575 ENDIF
576
577 IF ( ireelt == 1) THEN
578 field3(1:3) = 'N.A'
579 ENDIF
580
581
582 WRITE(iout,1002) unitab%UNIT_ID(i),field1,field2,field3,
583 . unitab%FAC_M(i),unitab%FAC_L(i),unitab%FAC_T(i)
584 ENDDO
585 ENDIF
586
587
588
589 DO n=1,nunits
590 IF (n >= 2) THEN
591
592 IF (unitab%FAC_M(n) == zero) THEN
593 unitab%FAC_M(n) = one
594 ELSE
595 unitab%FAC_M(n) = unitab%FAC_M(n) / unitab%FAC_M(1)
596 ENDIF
597
598 IF (unitab%FAC_L(n) == zero) THEN
599 unitab%FAC_L(n) = one
600 ELSE
601 unitab%FAC_L(n) = unitab%FAC_L(n) / unitab%FAC_L(1)
602 ENDIF
603
604 IF (unitab%FAC_T(n) == zero) THEN
605 unitab%FAC_T(n) = one
606 ELSE
607 unitab%FAC_T(n) = unitab%FAC_T(n) / unitab%FAC_T(1)
608 ENDIF
609
610 ENDIF
611 ENDDO
612 unitab%UNIT_ID(1) = 0
613 unitab%FAC_M(1) = fac_m_input / fac_mass
614 unitab%FAC_L(1) = fac_l_input / fac_length
615 unitab%FAC_T(1) = fac_t_input / fac_time
616
617 unitab%NUNITS = nunits
618
619 RETURN
620
6211000 FORMAT(
622 . //,' UNIT SYSTEMS DEFINITION '/
623 . ' ----------------------- ',/
624 ./ 58x,'MASS',16x,'LENGTH',14x,'TIME')
6251001 FORMAT
626 .(4x, 'WORK UNIT SYSTEM . . . . . . ','( ',a3,', ',a3,', ',a3,' )',
627 . 1pe20.13,1pe20.13,1pe20.13)
6281002 FORMAT
629 .(4x, 'UNIT SYSTEM, ID = ',i10,' ','( ',a3,', ',a3,', ',a3,' )',
630 . 1pe20.13,1pe20.13,1pe20.13)
6311003 FORMAT
632 .(4x, 'INPUT UNIT SYSTEM . . . . . ','( ',a3,', ',a3,', ',a3,' )',
633 . 1pe20.13,1pe20.13,1pe20.13)
subroutine hm_get_floatv_without_uid(name, rval, is_available)
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
subroutine hm_get_string(name, sval, size, is_available)
subroutine hm_option_count(entity_type, hm_option_number)
subroutine hm_option_start(entity_type)
integer, parameter nchartitle
integer, parameter ncharfield
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
subroutine udouble_wo_title(list, ilist, nlist, mess, ir, rlist)
subroutine unit_code(length, field, key, fac, ierr1, id)