-
Notifications
You must be signed in to change notification settings - Fork 10
/
Specact.FOR
7107 lines (7103 loc) · 226 KB
/
Specact.FOR
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
C
C
C
SUBROUTINE PSPECL
I (KEYST,KEYND,NDAMON,SDATIM,EDATIM,SPOUT,
I STFIL,
M RUNWID,
O CONDFG)
C
C + + + PURPOSE + + +
C Process the Special Actions block from UCI file.
C
C + + + HISTORY + + +
C 12/17/2004 jlk&pbd - added call to new subroutine to handle
C MFACT change action
C
C + + + DUMMY ARGUMENTS + + +
INTEGER KEYST,KEYND,NDAMON(12),SDATIM(5),EDATIM(5),SPOUT,
$ STFIL,RUNWID,CONDFG
C
C + + + ARGUMENT DEFINITIONS + + +
C KEYST - starting record number
C KEYND - ending record number
C NDAMON - no. of days in each month of calendar year
C SDATIM - starting date/time
C EDATIM - ending date/time
C SPOUT - runtime Special Action output level
C STFIL - unit number of status file
C RUNWID - maximum run span width allowed by user-defined variable
C quantities - 0 if no restrictions
C CONDFG - flag indicating whether conditinal special actions are
C used - 1 if yes, 2 if no
C
C + + + COMMON BLOCKS- SPEC + + +
INCLUDE 'cspec.inc'
C special action file in memory
INCLUDE 'pspins.inc'
INCLUDE 'cspins.inc'
C
C + + + PARAMETERS + + +
INTEGER MXSPBF,MXVACC
PARAMETER (MXSPBF=200000)
PARAMETER (MXVACC=50)
C
C + + + LOCAL VARIABLES + + +
INTEGER MESSU,MSGFL,SCLU,SGRP,BGRP,I1,ITYP,I,INITFG,CLEN,
$ CONT,LOCDIR,NVNMS,N,J,NVACC,VACFST(10),VACCNT(10),
$ TOPTYP,ERRFLG,DUMSUB(3),VRFADD(MXVACC),
$ VACADD(MXVACC),SPOS,SPBF(LENPSP,MXSPBF),
$ SPBDAT(MXSPBF),SPBPOS(MXSPBF),IOPT
CHARACTER*6 DUMNAM
CHARACTER*15 CRFADD(2),CACADD(2)
CHARACTER*80 CHSTR
C
C + + + EQUIVALENCES + + +
EQUIVALENCE (SPBF,SPBFR)
REAL SPBFR(LENPSP,MXSPBF)
EQUIVALENCE (CHSTR,CHSTR1)
CHARACTER*1 CHSTR1(80)
C
C + + + EXTERNALS + + +
EXTERNAL ZIPI,HDMES2,WMSGTT,MKADDR,PSPUCI,PSPKEY,PSPUMK
C
C + + + DATA INITIALIZATIONS + + +
DATA I1/1/
C
C + + + INPUT FORMATS + + +
1000 FORMAT (4X,A6,7I10)
1010 FORMAT (I10,10X,I10)
1020 FORMAT (3(A6,3I4,1X,I5,1X))
1030 FORMAT (5X,2I5)
1040 FORMAT (4(A15,1X))
C
C + + + OUTPUT FORMATS + + +
2000 FORMAT (/,' ',132('='),
$ /,' PROCESSING SPEC-ACTIONS BLOCK')
2010 FORMAT (/,' ',132('='),
$ /,' SPEC-ACTIONS BLOCK NOT FOUND')
2020 FORMAT (/,' NO SPECIAL ACTION ENTRIES FOUND TO PROCESS')
2030 FORMAT (/,' FINISHED PROCESSING SPEC-ACTIONS BLOCK',
$ /,' ',132('='))
C
C + + + END SPECIFICATIONS + + +
C
MESSU= FILE(1)
MSGFL= FILE(15)
C
SCLU= 203
BGRP= 100
C
CONDFG= 0
C
IF (SPOUT .GE. 10) THEN
C echo keys
WRITE (MESSU,*) 'KEYST,KEYND:',KEYST,KEYND
END IF
C
IF (KEYST .LE. 0) THEN
C no special action block to process
IF (OUTLEV .GT. 0) THEN
C message to that effect
WRITE (MESSU,2010)
END IF
ELSE
C special action uci instructions available
IOPT= 2
ITYP= 9
CALL HDMES2 (IOPT,ITYP,I1)
IF (OUTLEV .GT. 0) THEN
C processing message
WRITE (MESSU,2000)
END IF
C
IF (SPOUT .GE. 10) THEN
C echo dates
WRITE (MESSU,*) ' SDATIM:',SDATIM
WRITE (MESSU,*) ' EDATIM:',EDATIM
END IF
END IF
C
IF ( (KEYST .GE. 1) .OR. (STFIL .GE. 1) ) THEN
C either a block to process or need variable library for
C status file
C
C read info about which operations do special actions
I= 0
SGRP= 51
INITFG= 1
10 CONTINUE
CLEN= 80
I= I+ 1
CALL WMSGTT (MSGFL,SCLU,SGRP,INITFG,
M CLEN,
O CHSTR1,CONT)
READ (CHSTR,1000) OPTYLB(I),LOSPFL(I),LOSPST(I),LOSPKY(I),
$ LOSPLV(I),LOSPNU(I),LONAM(I),LONUM(I)
INITFG= 0
IF (CONT .EQ. 1) GO TO 10
C
C valid variable names from msgfl
SGRP= 52
INITFG= 1
CLEN= 80
CALL WMSGTT (MSGFL,SCLU,SGRP,INITFG,
M CLEN,
O CHSTR1,CONT)
READ (CHSTR,1010) NVNMS,LOCDIR
IF (SPOUT .GE. 10) THEN
C echo info
WRITE (MESSU,*) ' NVNMS,LOCDIR:',NVNMS,LOCDIR
END IF
C
C LOCDIR specs method(s) available for spec. actions input
C 0 - variable name required;
C 1 - either variable name or address required;
C 2 - address required
C
IF (LOCDIR .LE. 1) THEN
C read special actions variable name library from msgfl
SGRP= 53
INITFG= 1
DO 20 N= 1, NVNMS, 3
CLEN= 80
CALL WMSGTT (MSGFL,SCLU,SGRP,INITFG,
M CLEN,
O CHSTR1,CONT)
READ (CHSTR,1020) (VNAMLB(I),(VDIM(J,I),J=1,3),VLOC(I),
$ I= N, N+ 2)
INITFG= 0
IF ( (CONT .EQ. 0) .AND. (SGRP .EQ. 53) ) THEN
C go to next screen group
SGRP= 54
INITFG= 1
END IF
20 CONTINUE
END IF
END IF
C
IF (KEYST .GE. 1) THEN
C block is present - continue processing
C
C read special-action accumulator info and library
SGRP= 55
INITFG= 1
NVACC= 0
I= 0
30 CONTINUE
CLEN= 80
I= I+ 1
CALL WMSGTT (MSGFL,SCLU,SGRP,INITFG,
M CLEN,
O CHSTR1,CONT)
READ (CHSTR,1030) VACFST(I),VACCNT(I)
NVACC= NVACC+ VACCNT(I)
INITFG= 0
IF (CONT .EQ. 1) GO TO 30
C
SGRP= 56
INITFG= 1
DO 50 N= 1, NVACC, 2
CLEN= 80
CALL WMSGTT (MSGFL,SCLU,SGRP,INITFG,
M CLEN,
O CHSTR1,CONT)
READ (CHSTR,1040) CRFADD(1),CACADD(1),CRFADD(2),CACADD(2)
C
C process each address pair
DO 40 I= 1, 2
J= N+ I- 1
IF (J .LE. NVACC) THEN
C process this pair
C
C get reference address
TOPTYP= 0
ERRFLG= 0
CALL MKADDR (LOCDIR,CRFADD(I),MESSU,MSGFL,SCLU,BGRP,
M TOPTYP,ERRFLG,
O DUMNAM,DUMSUB,VRFADD(J))
IF (ERRFLG .EQ. 0) THEN
C get accumulator address
CALL MKADDR (LOCDIR,CACADD(I),MESSU,MSGFL,SCLU,BGRP,
M TOPTYP,ERRFLG,
O DUMNAM,DUMSUB,VACADD(J))
END IF
IF (ERRFLG .NE. 0) THEN
C don't use this reference
VRFADD(J)= 0
VACADD(J)= 0
END IF
END IF
40 CONTINUE
INITFG= 0
50 CONTINUE
C
C read and process lines from special actions block
C
CALL PSPUCI (MESSU,MSGFL,SCLU,KEYST,KEYND,LOCDIR,SDATIM,EDATIM,
I NDAMON,MXSPBF,MXVACC,VACFST,VACCNT,VRFADD,VACADD,
I LENPSP,SPOUT,
M RUNWID,CONDFG,
O SPOS,SPBF,SPBFR,SPBDAT)
C
IF (SPOS.GT.0 .OR. SPUMPT.GT.0) THEN
C at least one spec act is in memory.
IF (SPOS.GT.0) THEN
C sort special actions and generate keys
CALL PSPKEY (MESSU,MSGFL,SCLU,SPOS,MXSPBF,SPBDAT,SPBF,
I LENPSP,SPOUT,
O SPBPOS)
END IF
IF (SPUMPT.GT.0) THEN
C sort mult update instructions
CALL PSPUMK (SDATIM,NDAMON)
END IF
ELSE
C no entries found to process
IF (OUTLEV .GT. 0) THEN
C message to this effect
WRITE (MESSU,2020)
END IF
END IF
END IF
C
IF (SPOUT .GE. 10) THEN
C echo run width
WRITE (MESSU,*) ' runwid at end of pspecl',RUNWID
END IF
C
C all done special actions
IF (OUTLEV .GT. 0) THEN
C end processing message
WRITE (MESSU,2030)
END IF
C
RETURN
END
C
C
C
SUBROUTINE PSPUCI
I (MESSU,MSGFL,SCLU,KEYST,KEYND,LOCDIR,SDATIM,
I EDATIM,NDAMON,MXSPBF,MXVACC,VACFST,VACCNT,
I VRFADD,VACADD,LLNPSP,SPOUT,
M RUNWID,CONDFG,
O SPOS,SPBF,SPBFR,SPBDAT)
C
C + + + PURPOSE + + +
C Read and process Special Actions lines.
C
C + + + HISTORY + + +
C 4/14/2005 jlk - added initialization for I0
C 12/17/2004 jlk&pbd - added call to new subroutine to handle
C MFACT change action
C
C + + + DUMMY ARGUMENTS + + +
INTEGER MESSU,MSGFL,SCLU,KEYST,KEYND,LOCDIR,SDATIM(5),
$ EDATIM(5),NDAMON(12),MXSPBF,MXVACC,VACFST(10),
$ VACCNT(10),VRFADD(MXVACC),VACADD(MXVACC),LLNPSP,SPOUT,
$ RUNWID,CONDFG,SPOS,SPBF(LLNPSP,MXSPBF),SPBDAT(MXSPBF)
REAL SPBFR(LLNPSP,MXSPBF)
C
C + + + ARGUMENT DEFINITIONS + + +
C MESSU - unit number to write messages on
C MSGFL - unit number for file containing error messages
C SCLU - cluster in file containing error text
C KEYST - starting record number
C KEYND - ending record number
C LOCDIR - specs method(s) available for spec. actions input
C SDATIM - starting date/time
C EDATIM - ending date/time
C NDAMON - no. of days in each month of calendar year
C MXSPBF - max size of special actions buffer
C MXVACC - maximum number of variable accumulator references
C VACFST - first variable accumulator reference for each operation type
C VACCNT - number of variable accumulator references for each operation type
C VRFADD - variable accumulator reference addresses
C VACADD - variable accumulator addresses
C LLNPSP - local length of special action in buffer
C SPOUT - runtime Special Action output level
C RUNWID - maximum run span width allowed by user-defined variable
C quantities - 0 if no restrictions
C CONDFG - flag indicating whether conditinal special actions are
C used - 1 if yes, 2 if no
C SPOS - position in special actions instr buffer
C SPBF - special action instruction buffer (integer version)
C SPBFR - special action instruction buffer (real version)
C SPBDAT - special action instruction date
C
C + + + COMMON BLOCKS- SPEC + + +
INCLUDE 'cspec.inc'
C special action distributions
INCLUDE 'pspdst.inc'
INCLUDE 'cspdst.inc'
C special action file in memory
INCLUDE 'pspins.inc'
INCLUDE 'cspins.inc'
C user defined variable names
INCLUDE 'pspuvr.inc'
INCLUDE 'cspuvr.inc'
C special action conditions
INCLUDE 'pspcnd.inc'
INCLUDE 'cspcnd.inc'
C user defined variable quantity definitions
INCLUDE 'pspvqd.inc'
INCLUDE 'cspvqd.inc'
C
C + + + PARAMETERS + + +
INTEGER MXBKLV
PARAMETER (MXBKLV=25)
C
C + + + LOCAL VARIABLES + + +
INTEGER CURBLK,CURLVL,PREBLK(MXBKLV),ELSEFG(MXBKLV),I0,DELT,
$ KEY,I,STWORD,SGRP,FIRSTH,NUMHDR,ALLHDR,ALLFTR,LREPT,
$ IOPT,DCNT
CHARACTER*80 UCIBUF
C
C + + + FUNCTIONS + + +
INTEGER CKNBLV
C
C + + + EXTERNALS + + +
EXTERNAL ZIPI,GETUCI,PSPUVQ,PSPCON,PSPDIS,PSPUVN,PSPACT,OMSG
EXTERNAL CKNBLV,PSPIPS,PSPHDR,HDMES3,PSPUML
C
C + + + DATA INITIALIZATIONS + + +
DATA I0/0/
C + + + END SPECIFICATIONS + + +
C
C start with no actions stored
SPOS= 0
FIRSTH= 0
NUMHDR= 0
ALLHDR= 0
ALLFTR= 0
LREPT= 1
C
C no conditions stored
NCOND= 0
NCHAIN= 0
NBLOCK= 0
CALL ZIPI (MXSPCH,I0,CHNUVQ)
C
C initialize logical blocks
CURBLK= 0
CURLVL= 0
CALL ZIPI (MXBKLV,I0,PREBLK)
CALL ZIPI (MXBKLV,I0,ELSEFG)
C
C no distributions stored
DCNT= 0
CALL ZIPI (MXSPDS,I0,SPDCNT)
C
C no user defined special actions
SPUCNT= 0
C info about first referenced variable starts at first position
SPUPOS(1)= 1
C
C no user defined variable quantities
NVQD= 0
CALL ZIPI (MXSPVQ,I0,
O UVQOPX)
C
C no update mfact instructions stored
SPUMPT = 0
C
C set run time step
DELT= GRPTAB(3,1)
C
C where to start
KEY= KEYST
C output header position
IOPT = 4
C
C begin whiledo to read lines
10 CONTINUE
C
C read a uci entry
CALL GETUCI (I0,
M KEY,
O UCIBUF)
IF (KEY .NE. KEYND) THEN
C this is not the last line in block
IF (SPOUT .GE. 10) THEN
C echo key
WRITE (MESSU,*)
WRITE (MESSU,*) 'read UCI:',KEY
END IF
C
IF (UCIBUF(1:4) .EQ. 'MULT') THEN
C this is an mfact update line
CALL HDMES3 (IOPT,'MULT')
CALL PSPUML (UCIBUF,MESSU,OUTLEV,MSGFL,SCLU,SPOUT,CURBLK,
M ECOUNT)
ELSE
C find first word in case line is a free-form conditional line
I= 80
STWORD= CKNBLV (I,UCIBUF)
IF (STWORD .LT. 1) THEN
C set dummy stword on blank line
STWORD= 1
END IF
C
IF (UCIBUF(STWORD:STWORD+2) .EQ. '@@@') THEN
C special action echo file header for next action line
CALL PSPHDR (UCIBUF,
M FIRSTH,NUMHDR,ALLHDR)
C
ELSE IF (UCIBUF(3:8) .EQ. 'UVQUAN') THEN
C user defined variable quantity name
CALL HDMES3 (IOPT,'UVQUAN')
CALL PSPUVQ (UCIBUF,MESSU,OUTLEV,MSGFL,SCLU,LOCDIR,
I DELT,MAXOPN,OPNTAB,NOPNS,SPOUT,OPTYL1,
M ECOUNT,RUNWID)
C
ELSE IF ( (UCIBUF(STWORD:STWORD+2) .EQ. 'IF ') .OR.
$ (UCIBUF(STWORD:STWORD+3) .EQ. 'ELSE') .OR.
$ (UCIBUF(STWORD:STWORD+5) .EQ. 'END IF') ) THEN
C conditional
CALL HDMES3 (IOPT,'CONDITIONAL')
CALL PSPCON (OUTLEV,MESSU,MSGFL,SCLU,MXBKLV,STWORD,LREPT,
I LLNPSP,MXSPBF,SPOS,
M SPBF,ECOUNT,UCIBUF,KEY,CURBLK,CURLVL,PREBLK,
M ELSEFG,ALLFTR,RUNWID)
CONDFG= 1
C
ELSE IF (UCIBUF(3:8) .EQ. 'DISTRB') THEN
C distribute action definition
CALL HDMES3 (IOPT,'DISTRB')
CALL PSPDIS (UCIBUF,MESSU,MSGFL,SCLU,MXSPDS,OUTLEV,SPOUT,
M DCNT,SPDCNT,SPDTST,SPDTCD,SPDDFG,SPDFRC,
M ECOUNT)
C
ELSE IF (UCIBUF(3:8) .EQ. 'UVNAME') THEN
C user defined action name
CALL HDMES3 (IOPT,'UVNAME')
CALL PSPUVN (MESSU,MSGFL,SCLU,OUTLEV,LOCDIR,SPOUT,
M ECOUNT,UCIBUF,KEY)
C
ELSE
C old style action
CALL HDMES3 (IOPT,'CLASSIC')
CALL PSPACT (UCIBUF,MESSU,MSGFL,SCLU,LOCDIR,SDATIM,
I EDATIM,NDAMON,MXSPBF,MXSPDS,SPDCNT,DELT,
I CURBLK,VACFST,VACCNT,MXVACC,VRFADD,VACADD,
I SPOUT,LENPSP,
M FIRSTH,NUMHDR,LREPT,SPOS,SPBF,SPBFR,SPBDAT,
M RUNWID)
C
END IF
END IF
C
END IF
IF (KEY .NE. KEYND) GO TO 10
C
IF (SPOUT .GE. 10) THEN
C echo number of special actions
WRITE (MESSU,*) 'finished processing special action entries',
$ SPOS
END IF
C
C check to make sure logic blocks were correctly closed
IF ( (CURLVL .NE. 0) .OR. (CURBLK .NE. 0) ) THEN
C error - ifs and endifs don't match up
SGRP= 28
CALL OMSG (MESSU,MSGFL,SCLU,SGRP,
M ECOUNT)
END IF
C
IF (NVQD .GE. 1) THEN
C handle pipes for user-defined variable quantities
CALL PSPIPS (MESSU,MSGFL,SCLU,SPOUT,
M RUNWID)
END IF
C
C write (99,*) 'numhdr,mxsphf',NUMHDR,' of',MXSPHF
C write (99,*) 'spos ,mxspin',SPOS, ' of',MXSPIN
C write (99,*) 'nvqd ,mxspvq',NVQD, ' of',MXSPVQ
C write (99,*) 'ncond ,mxspcn',NCOND, ' of',MXSPCN
C write (99,*) 'nblock,mxspbk',NBLOCK,' of',MXSPBK
C write (99,*) 'nchain,mxspch',NCHAIN,' of',MXSPCH
C IF (NBLOCK .GE. 1) THEN
C I= BLKPOS(NBLOCK)+ BLKCNT(NBLOCK)- 1
C ELSE
C I= 0
C END IF
C write (99,*) 'nchref,mxspcr',I, ' of',MXSPCR
C write (99,*) 'spucnt,mxspuv',SPUCNT,' of',MXSPUV
C IF (SPUCNT .GE. 1) THEN
C I= SPUPOS(SPUCNT+1)
C ELSE
C I= 0
C END IF
C write (99,*) 'spuptr,mxspux',I, ' of',MXSPUX
C I= 0
C DO 991 KEY= 1, NBLOCK
C IF (BLKLVL(KEY) .GT. I) THEN
C I= BLKLVL(KEY)
C END IF
C 991 CONTINUE
C write (99,*) 'deeplv,mxbklv',I, ' of',MXBKLV
C
RETURN
END
C
C
C
SUBROUTINE PSPKEY
I (MESSU,MSGFL,SCLU,SPOS,MXSPBF,SPBDAT,SPBF,
I LLNPSP,SPOUT,
O SPBPOS)
C
C + + + PURPOSE + + +
C Sort Special Actions for each operation and set OSV keys.
C
C + + + DUMMY ARGUMENTS + + +
INTEGER MESSU,MSGFL,SCLU,SPOS,MXSPBF,SPBDAT(MXSPBF),LLNPSP,
$ SPBF(LLNPSP,MXSPBF),SPOUT,SPBPOS(MXSPBF)
C
C + + + ARGUMENT DEFINITIONS + + +
C MESSU - unit number to write messages on
C MSGFL - unit number for file containing error messages
C SCLU - cluster in file containing error text
C SPOS - position in special actions instr buffer
C MXSPBF - max size of special actions buffer
C SPBDAT - special action instruction date
C SPBF - special action instruction buffer
C LLNPSP - local length of special action in buffer
C SPOUT - runtime Special Action output level
C SPBPOS - special action sorted position
C
C + + + COMMON BLOCKS- SPEC + + +
INCLUDE 'cspec.inc'
C special action file in memory
INCLUDE 'pspins.inc'
INCLUDE 'cspins.inc'
C osv in scratch pad
INCLUDE 'cmosv.inc'
INCLUDE 'cmpad.inc'
C
C + + + LOCAL VARIABLES + + +
INTEGER SPAKEY,SORTOP,TOPTYP,SPAKST,OSVKEY,OSVSIZ,XPOS,IPOS,
$ TOPFST,TOPLST,FIT,ADDR,I,J,LOGBLK,I0,I1,CONDCK,SGRP,
$ SKEY,DATED,UNDAT,PKEY,SPNUND
CHARACTER*6 OPTYP
C
C + + + FUNCTIONS + + +
INTEGER OPNNO
C
C + + + EXTERNALS + + +
EXTERNAL ASRTI,GETOSV,OPNNO,OMSG,PUTOSV
C
C + + + DATA INITIALIZATIONS + + +
DATA I0,I1/0,1/
C
C + + + OUTPUT FORMATS + + +
2000 FORMAT (A4,A2)
C
C + + + END SPECIFICATIONS + + +
C
C no special actions saved
SPAKEY= 0
C
IF (SPOUT .GE. 10) THEN
C echo header
WRITE (MESSU,*)
WRITE (MESSU,*) '------ sorting special actions -------'
END IF
C sort special action instructions in place by date
SORTOP= 0
CALL ASRTI (SORTOP,SPOS,SPBDAT,
O SPBPOS)
C
C process special actions through each operation in the run
SPWSIV= 0
DO 100 OPNO= 1,NOPNS
SPNUND= 0
TOPTYP= OPNTAB(4,OPNO)
IF (SPOUT .GE. 10) THEN
C echo operaton info
WRITE (MESSU,*)
WRITE (MESSU,*) '*** OPNO :',OPNO,TOPTYP,LOSPFL(TOPTYP)
END IF
IF (LOSPFL(TOPTYP) .GT. 0) THEN
C this operation is capable of handling special actions
C assume no special actions in this operation
SPAKST= 0
C how big is osv for this operation
OSVKEY= OPNTAB(7,OPNO)
OSVSIZ= (1 + OPNTAB(8,OPNO) - OSVKEY)*500
IF (SPOUT .GE. 10) THEN
C echo osv info
WRITE (MESSU,*) ' OSVKEY:',OSVKEY,OSVSIZ
END IF
C read in the first osv-chunk for this operation
CALL GETOSV (OSVKEY,OSVKEY,MAXOSV,
O OSV)
C loop thru instructions
DO 30 XPOS= 1, SPOS
C see if current operation fits in the given range
IPOS= SPBPOS(XPOS)
WRITE (OPTYP,2000) SPBF(15,IPOS),SPBF(16,IPOS)
TOPFST = SPBF(17,IPOS)
TOPLST = SPBF(18,IPOS)
FIT= OPNNO (OPTYP,TOPFST,TOPLST,MAXOPN,OPNTAB,OPNO,OPNO)
IF (SPOUT .GE. 10) THEN
C echo info
WRITE (MESSU,*) ' FIT:',FIT,TOPFST,TOPLST,XPOS,
$ IPOS
END IF
IF (FIT .GT. 0) THEN
C the entry does apply to this opn
ADDR= SPBF(7,IPOS)
IF (ADDR .LE. OSVSIZ) THEN
C special action within active osv space for opn
C write instruction to runtime buffer
SPAKEY= SPAKEY+ 1
IF (SPAKST .EQ. 0) THEN
C first instruction for this opn, set flag pointer
SPAKST= SPAKEY
IF (SPOUT .GE. 10) THEN
C echo first key
WRITE (MESSU,*) ' first at:',SPAKEY
END IF
END IF
IF (SPOUT .GE. 10) THEN
C echo instruction
WRITE (MESSU,*) ' instr at:',SPAKEY,
$ (SPBF(J,IPOS),J=1,5)
END IF
DO 10 J= 1,14
SPINS(J,SPAKEY)= SPBF(J,IPOS)
10 CONTINUE
DO 20 J= 15, LENSPI
I= J+ 4
SPINS(J,SPAKEY)= SPBF(I,IPOS)
20 CONTINUE
C
C set initial sort pointer to use if no undated
SPPTR(SPAKEY)= SPAKEY
C
IF (SPINS(1,SPAKEY) .EQ. 0) THEN
C this action undated
SPNUND= SPNUND+ 1
END IF
C
C check condition if present
LOGBLK= SPINS(18,SPPTR(SPAKEY))
IF (LOGBLK .GT. 0) THEN
C check condition for proper formation
CALL SPBKCK (LOGBLK,I1,OPNO,I0,MESSU,
O CONDCK)
IF (CONDCK .EQ. -1) THEN
C error - stack overflow
SGRP= 25
CALL OMSG (MESSU,MSGFL,SCLU,SGRP,
M ECOUNT)
ELSE IF (CONDCK .EQ. -2) THEN
C error - stack underflow
SGRP= 26
CALL OMSG (MESSU,MSGFL,SCLU,SGRP,
M ECOUNT)
ELSE IF (CONDCK .EQ. -3) THEN
C error - program bug - stack not cleared
SGRP= 27
CALL OMSG (MESSU,MSGFL,SCLU,SGRP,
M ECOUNT)
END IF
END IF
ELSE
C not part of active osv
IF (SPOUT .GE. 10) THEN
C echo no instruction message
WRITE (MESSU,*) ' NO instr:',ADDR,OSVSIZ
END IF
END IF
END IF
30 CONTINUE
C
IF (SPNUND .GT. 0) THEN
C separate into dated and undated pools and rewrite pointers
DATED= 0
UNDAT= 0
IF (SPOUT .GE. 10) THEN
WRITE (MESSU,*) 'opno,spakst,spakey,spnund',OPNO,SPAKST,
$ SPAKEY,SPNUND
END IF
DO 40 SKEY= SPAKST, SPAKEY
IF (SPINS(1,SKEY) .EQ. 0) THEN
C place in undated pool
UNDAT= UNDAT+ 1
PKEY= SPAKEY- SPNUND+ UNDAT
ELSE
C place in dated pool
DATED= DATED+ 1
PKEY= SPAKST- 1+ DATED
END IF
SPPTR(PKEY)= SKEY
40 CONTINUE
I= UNDAT+ DATED- (SPAKEY- SPAKST+ 1)
IF (SPOUT .GE. 10) THEN
WRITE (MESSU,*) ' should be zero:',I
DO 45 PKEY= SPAKST,SPAKEY
WRITE (MESSU,*) ' pkey,spptr(pkey)',PKEY,SPPTR(PKEY)
45 CONTINUE
END IF
END IF
C
IF (SPAKST .GT. 0) THEN
C space key to this instruction
C WRITE(99,*)'KEYS',TOPTYP,LOSPST(TOPTYP),LOSPKY(TOPTYP),
C $ LOSPLV(TOPTYP),LOSPNU(TOPTYP)
IPOS= LOSPST(TOPTYP)
OSV(IPOS)= SPAKST
C final key
IPOS= LOSPKY(TOPTYP)
OSV(IPOS)= SPAKEY
C special action output level
IPOS= LOSPLV(TOPTYP)
OSV(IPOS)= SPOUT
C number of undated actions
IPOS= LOSPNU(TOPTYP)
OSV(IPOS)= SPNUND
IF (SPOUT .GE. 10) THEN
C echo keys
WRITE (MESSU,*) ' into OSV:',SPAKST,SPAKEY
END IF
ELSE
C no instructions written, update osv to indicate that
IPOS= LOSPST(TOPTYP)
OSV(IPOS)= 0
IPOS= LOSPKY(TOPTYP)
OSV(IPOS)= 0
IPOS= LOSPLV(TOPTYP)
OSV(IPOS)= 0
IPOS= LOSPNU(TOPTYP)
OSV(IPOS)= 0
IF (SPOUT .GE. 10) THEN
C echo no actions message
WRITE (MESSU,*) ' ** no actions for this operation'
END IF
END IF
C
C write osv-chunk back to disc
CALL PUTOSV (OSVKEY,OSVKEY,MAXOSV,OSV)
ELSE
C special actions not allowed for this operation type
IF (SPOUT .GE. 10) THEN
C echo not allowed message
WRITE (MESSU,*) ' no spec actions op type',TOPTYP
END IF
END IF
C end operation loop
100 CONTINUE
C
RETURN
END
C
C
C
SUBROUTINE PSPIPS
I (MESSU,MSGFL,SCLU,SPOUT,
M RUNWID)
C
C + + + PURPOSE + + +
C Determine lengths of pipes for user-defined variable quantities
C and initialize from starting OSV value of base variable
C
C + + + DUMMY ARGUMENTS + + +
INTEGER MESSU,MSGFL,SCLU,SPOUT,RUNWID
C
C + + + ARGUMENT DEFINITIONS + + +
C MESSU - unit number to write messages on
C MSGFL - unit number for file containing error messages
C SCLU - cluster in file containing error text
C SPOUT - runtime Special Action output level
C RUNWID - maximum run span width allowed by user-defined variable
C quantities - 0 if no restrictions
C
C + + + COMMON BLOCKS + + +
INCLUDE 'cspec.inc'
C user-defined variable quantity
INCLUDE 'pspvqd.inc'
INCLUDE 'cspvqd.inc'
C osv in scratch pad
INCLUDE 'cmosv.inc'
INCLUDE 'cmpad.inc'
C
C + + + LOCAL VARIABLES + + +
INTEGER LSTPTR,MINPIP,ERRFLG,EXTRA,SGRP,I,KEYST,KEYND,
$ OSVLEN,I6,PTR
DOUBLE PRECISION DVAL
CHARACTER*6 OBUFF
C
C + + + EQUIVALENCES + + +
EQUIVALENCE (OBUFF,OBUF1)
CHARACTER*1 OBUF1(6)
C
C + + + FUNCTIONS + + +
INTEGER DADDR
C
C + + + INTRINSICS + + +
INTRINSIC MAX,SNGL
C
C + + + EXTERNALS + + +
EXTERNAL OMSTI,OMSG,OMSTC,GETOSV,DADDR
C
C + + + DATA INITIALIZATIONS + + +
DATA I6/6/
C
C + + + OUTPUT FORMATS + + +
2000 FORMAT (/,' USER-DEFINED VARIABLE QUANTITIES - POINTERS AND',
$ ' PIPE',/,/,' NAME POS LEN VALUE')
2010 FORMAT (2X,A6,2I5,I12)
2020 FORMAT (2X,A6,2I5,G12.5)
C
C + + + END SPECIFICATIONS + + +
C
ERRFLG= 0
LSTPTR= 0
EXTRA= 0
C
C check run width restriction
IF (RUNWID .EQ. -1) THEN
C run width restriction still must be determined
C first try evenly dividing availiable pipe among all uvquans
RUNWID= MXPIPE / NVQD
C
C check to make sure all pipes fit
DO 10 I= 1, NVQD
MINPIP= UVQLAG(I)+ UVQAGG(I)
IF (MINPIP .GT. RUNWID) THEN
C must allocate extra space to this pipe
EXTRA= EXTRA+ MINPIP- RUNWID
END IF
10 CONTINUE
IF (EXTRA .GT. 0) THEN
C reduce run width to make room for extra space
RUNWID= RUNWID- (EXTRA- 1)/NVQD - 1
IF (RUNWID .LT. 1) THEN
C error - too many lags and aggs for so many uvquans
CALL OMSTI (MXPIPE)
SGRP= 90
CALL OMSG (MESSU,MSGFL,SCLU,SGRP,
M ECOUNT)
ERRFLG= 1
END IF
END IF
END IF
C
IF (ERRFLG .EQ. 0) THEN
C calculate pointers and initialize pipe
DO 50 I= 1, NVQD
UVQPOS(I)= LSTPTR+ 1
UVQLEN(I)= MAX (RUNWID,UVQLAG(I)+ UVQAGG(I))
LSTPTR= UVQPOS(I)+ UVQLEN(I)- 1
IF (LSTPTR .GT. MXPIPE) THEN
C error - pipe overflow
CALL OMSTI (MXPIPE)
SGRP= 90
CALL OMSG (MESSU,MSGFL,SCLU,SGRP,
M ECOUNT)
ERRFLG= 1
ELSE
C this uvquan fits in pipe
IF (SPOUT .GE. 10) THEN
C echo pipe info
WRITE (MESSU,*) ' pipe first,length,last',UVQPOS(I),
$ UVQLEN(I),LSTPTR
END IF
END IF
C
IF (ERRFLG .EQ. 0) THEN
C initialize pipe to initial value in OSVM
IF (UVQOPX(I) .EQ. 0) THEN
C base variable is in workspace - set to zero
DO 20 PTR= UVQPOS(I), LSTPTR
IVQPIP(PTR)= 0
20 CONTINUE
ELSE IF (UVQOPX(I) .EQ. -1) THEN
C base variable is boolean value of a logic chain - set to undefined
DO 30 PTR= UVQPOS(I), LSTPTR
IVQPIP(PTR)= -1
30 CONTINUE
ELSE
C base variable is in an osv
KEYST= OPNTAB(7,UVQOPX(I))
KEYND= OPNTAB(8,UVQOPX(I))
OSVLEN= (KEYND- KEYST+ 1)* 500
IF (UVQADD(I) .LE. OSVLEN) THEN
C base variable is in active osv - not necessarily
C in active section!
CALL GETOSV (KEYST,KEYND,MAXOSV,
O OSV)
DO 40 PTR= UVQPOS(I), LSTPTR
IF (UVQTYP(I) .EQ. 2) THEN
C integer
IVQPIP(PTR)= IPAD(UVQADD(I))
ELSE IF (UVQTYP(I) .EQ. 3) THEN
C real
IF (IPAD(UVQADD(I)) .NE. -999) THEN
C valid real
UVQPIP(PTR)= PAD(UVQADD(I))
ELSE
C undefined - set to zero
UVQPIP(PTR)= 0.0
END IF
ELSE IF (UVQTYP(I) .EQ. 4) THEN
C double precision
IF (IPAD(UVQADD(I)) .NE. -999) THEN
C valid double precision
DVAL= DPPAD(DADDR (UVQADD(I)))
UVQPIP(PTR)= SNGL (DVAL)
ELSE
C undefined - set to zero
UVQPIP(PTR)= 0.0
END IF
END IF
C
40 CONTINUE
ELSE
C error - base variable address is outside of osv
OBUFF= UVQNAM(I)
CALL OMSTC (I6,OBUF1)
CALL OMSTI (UVQADD(I))
CALL OMSTI (OSVLEN)
SGRP= 91
CALL OMSG (MESSU,MSGFL,SCLU,SGRP,
M ECOUNT)
ERRFLG= 1
END IF
END IF
IF (SPOUT .GE. 10) THEN
C echo entire pipe
IF (UVQTYP(I) .EQ. 2) THEN
C integer
WRITE (MESSU,*) ' pipe',(IVQPIP(PTR), PTR= UVQPOS(I),
$ LSTPTR)
ELSE
C real or dp
WRITE (MESSU,*) ' pipe',(UVQPIP(PTR), PTR= UVQPOS(I),
$ LSTPTR)
END IF
END IF
END IF
C
IF ( (ERRFLG .EQ. 0) .AND. (UVQOPX(I) .GE. 0) ) THEN
C echo pointers and pipes for all but internal boolean pipes
IF (OUTLEV .GT. 2) THEN
C echo to message unit
IF (I .EQ. 1) THEN
C echo header lines
WRITE (MESSU,2000)
END IF
IF (UVQTYP(I) .EQ. 2) THEN
C integer
WRITE (MESSU,2010) UVQNAM(I),UVQPOS(I),
$ UVQLEN(I),
$ IVQPIP(UVQPOS(I))
ELSE
C real or real from dp