-
Notifications
You must be signed in to change notification settings - Fork 0
/
glstuff.F
1665 lines (1485 loc) · 44.5 KB
/
glstuff.F
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
#ifdef sgi_display
c-----------------------------------------------------------------------
c
c
c sgi graphics stuff
c
c author: c. h. goldberg e.mail==>chg@gfdl.gov
c
c-----------------------------------------------------------------------
c
subroutine initdisplay
c colors uniformly distributed by depth: range = [-zw(km)..0.0]
#define depth_colors
c colors uniformly distributed by kmt: range = [km..0]
c#define kmt_colors
c lighten all colors by adding white [may print better]
c#define pastel_colors
#include "glstuff.h"
c#include "/usr/include/fdevice.h"
c#include "/usr/include/fgl.h"
c#include "/usr/include/fget.h"
#include "fdevice.h"
#include "fgl.h"
c#include "fget.h"
integer *2 data
integer*4 p(2)
#include "size.h"
character *32 title
c
c-----------------------------------------------------------------------
c
c initialize graphics display server
c
c these next two initialization lines are currently unnecessary,
c but worth remembering. they open a pseudo remote DGL connection.
c
c iserv = dglope ('chg', 3, DGLTSO)
c print *, 'iserv=',iserv
c
c If the next GL call is not made, the entire executable becomes
c a background job at the first GL library call, and commands in
c the run script after the execute command begin executing before
c the run is completed.
c
call foregr
c
call initscolor
nrwindows = 0
c
imainmap = 1
i = imainmap
iwd(i) = 1280
iht(i) = iwd(i)/2
c make main map window (360 x 180) degrees
ix1 = 0
iy1 = 10
ix2 = ix1 + iwd(i) - 1
iy2 = iy1 + iht(i) - 1
title = 'mainmap'
call makewindow (imainmap, title, midgray, 'prefpo',
& 0.0, 360.0, -90.0, 90.0,
& ix1, ix2, iy1, iy2)
icurrentwin = iwin(imainmap)
c
c make interation window
c
iterwin = 2
title = 'i'
iwidth = 90
iheight = 30
call makewindow (iterwin, title, midgray, 'prefpo',
& -0.5, 0.5, -0.5, 0.5,
& ix2-100,ix2-100+iwidth, iy2+120,iy2+120+iheight)
c
c make a color bar
c
icolorbar = 3
idy = 30
iy3 = iy2+idy
iy4 = iy3 + 50
title = 'depths'
call makewindow (icolorbar, title, midgray, 'prefpo',
& -0.5, maxscolor+0.5, -0.5, 50.5,
& ix1+iwd(imainmap)/3, ix2, iy2+idy, iy2+idy+50)
do ix = 0, maxscolor
call cpack (scolor(ix))
call gl_rectf (ix-0.5, -0.5, ix+0.5, 50.0+0.5)
end do
c make edit/zoom map window
izoom = 4
i = izoom
iwd(i) = iwd(imainmap)/3
iht(i) = iwd(i)
title = 'edit window'
call makewindow (izoom, title, midgray, 'prefpo',
& 0.0, 360.0, -90.0, 90.0,
& ix1, ix1+iwd(izoom), 1023-30-iht(izoom), 1023-30)
c
c make mouse button prompt window
iprompt = 5
i = iprompt
iwd(i) = iwd(imainmap)/3
iht(i) = iwd(i)/4
lz = 200
title = 'mouse buttons'
ix5 = ix1+iwd(izoom)+20
iy5 = iy4 + 30
call makewindow (iprompt, title, midgray, 'prefpo',
& 0.5, 3.5, -0.5, 0.5,
& ix5, ix5+iwd(i), iy5, iy5+50)
c
c make "leave interactive edit" button window
iquit = 6
i = iquit
iwd(i) = iwd(iprompt)/3
iht(i) = iht(iprompt)
title = 'quit'
ix6 = ix5+iwd(iprompt)/3
iy6 = iy5 + 80
call makewindow (iquit, title, midgray, 'prefpo',
& -0.5, 0.5, -0.5, 0.5,
& ix6, ix6+iwd(i), iy6, iy6+50)
c
c define window numbers for two additional map windows
c but do not make them yet
c
c
call clear_edit_window
c
call winset (iwin(imainmap))
c
c enable input devices [a winope call must precede these]
c
call qdevic (KEYBD)
call qdevic (LEFTMO)
call qdevic (RIGHTM)
call qdevic (MIDDLE)
call qdevic (MOUSEX)
call qdevic (MOUSEY)
leftmouse = .false.
middlemouse = .false.
rightmouse = .false.
mx = 0
my = 0
c
#ifdef debug_glstuff
c initialization complete, now test features
c
c get window origin
call getori (ixo, iyo)
print *, 'window origin=', ixo, iyo
c get number of bit planes
nbp = getpla ()
print *, 'number of bit planes = ',nbp
call cmov2i (175, 87)
call cpack (scolor(2*ngray))
call charst ('hello', 5)
#endif
return
end
c-----------------------------------------------------------------------
c
subroutine reldisplay
#include "glstuff.h"
c
do i=imainmap,iquit
call winclo (iwin(imainmap))
end do
return
end
c-----------------------------------------------------------------------
c
subroutine make_extra_map_windows
#include "glstuff.h"
character *32 title
c
call winclo(izoom)
call winclo(iprompt)
call winclo(iquit)
c make second map window
imap2 = 7
i = imap2
iwd(i) = iwd(imainmap)*45/100
iht(i) = iwd(i)/2
c
ix1 = 0
iy1 = 10
ix7 = ix1
iy7 = iy1 + iht(imainmap) + 30
ix8 = ix7 + iwd(i) - 1
iy8 = iy7 + iht(i) - 1
title = 'map2'
call makewindow (imap2, title, midgray, 'prefpo',
& 0.0, 360.0, -90.0, 90.0,
& ix7, ix8, iy7, iy8)
c make third map window
imap3 = 8
i = imap3
iwd(i) = iwd(imap2)
iht(i) = iwd(i)/2
c
ix9 = ix8 + 15
iy9 = iy7
ix10 = ix9 + iwd(i) - 1
iy10 = iy9 + iht(i) - 1
title = 'map3'
call makewindow (imap3, title, midgray, 'prefpo',
& 0.0, 360.0, -90.0, 90.0,
& ix9, ix10, iy9, iy10)
return
end
c-----------------------------------------------------------------------
subroutine initscolor
c
c make colors for a color bar
c
#include "glstuff.h"
integer rcolor, gcolor, bcolor
parameter (rcolor=1, gcolor=256, bcolor=256*256)
integer r, g, b, maxc
parameter (maxc=255)
parameter (gamma=real(maxc)/ngray)
parameter (ncolorsteps=20)
do is = 0,ngray-1
call rgbtopack (0,
& nint(is * gamma),
& nint(ngray * gamma),
& scolor (is))
end do
do is = 0,ngray-1
call rgbtopack (0,
& nint(ngray * gamma),
& nint((ngray-is) * gamma),
& scolor (is+ngray))
end do
do is = 0,ngray-1
call rgbtopack (nint(is * gamma),
& nint(ngray * gamma),
& 0,
& scolor (is+2*ngray))
end do
do is = 0,ngray-1
call rgbtopack (nint(ngray * gamma),
& nint((ngray-is) * gamma),
& 0,
& scolor (is+3*ngray))
end do
call rgbtopack (nint(ngray * gamma),
& 0,
& 0,
& scolor (4*ngray))
c
c create slightly darker contour bands
c
do is = 0,maxscolor
if (mod((is*ncolorsteps)/maxscolor,2) .eq. 0) then
call packtorgb (scolor(is), r, g, b)
call rgbtopack (r*9/10, g*9/10, b*9/10, scolor(is))
end if
end do
#ifdef pastel_colors
do is = 0,maxscolor
call packtorgb (scolor(is), r, g, b)
c call rgbtopack ((r+maxc)/2, (g+maxc)/2, (b+maxc)/2, scolor(is))
call rgbtopack ((2*r+maxc)/3, (2*g+maxc)/3, (2*b+maxc)/3,
& scolor(is))
end do
#endif
return
end
c-----------------------------------------------------------------------
subroutine rgbtopack (r, g, b, rgb)
integer r, g, b, rgb
integer rcolor, gcolor, bcolor
parameter (rcolor=1, gcolor=256, bcolor=256*256)
rgb = r * rcolor + g * gcolor + b * bcolor
return
end
c-----------------------------------------------------------------------
subroutine packtorgb (rgb, r, g, b)
integer r, g, b, rgb
integer rcolor, gcolor, bcolor
parameter (rcolor=1, gcolor=256, bcolor=256*256)
r = mod (rgb, 256)
g = mod (rgb/256, 256)
b = mod (rgb/(256*256), 256)
return
end
c-----------------------------------------------------------------------
subroutine plotpoint (ix, iy, icolor)
call cpack (icolor)
call gl_rectf (ix-0.5, iy-0.5, ix+0.5, iy+0.5)
return
end
c-----------------------------------------------------------------------
function ilcolor (v, vmin, vmax, cmin, cmax)
c
c select a color based on log(abs(v))
c
integer cmin, cmax
#include "glstuff.h"
if (v .eq. 0) then
call rgbtopack (64, 32, 0, ilcolor)
else
is = maxscolor * (log(abs(v))-log(vmin))/
& (log(vmax) -log(vmin))
is = min (is, maxscolor)
c is = max (is, 0)
if (is .ge. 0) then
ilcolor = scolor (mod(is,maxscolor+1))
else
is = max(is, -128)
call rgbtopack (0,0,255+is, ilcolor)
c ilcolor = 0
end if
end if
return
end
c-----------------------------------------------------------------------
function iscolor (v, vmin, vmax, cmin, cmax)
c
c select a color based on v
c
integer r, g, b
integer cmin, cmax
#include "glstuff.h"
if (v .gt. vmax) then
is = cmax
iscolor = scolor(cmax)
c call rgbtopack (255,192,192, iscolor)
else if (v .lt. vmin) then
is = cmin
iscolor = scolor(cmin)
c iscolor = 0
else if (v .eq. 0.0) then
iscolor = iwhite
else
is = cmin + (cmax-cmin) * (v-vmin)/(vmax-vmin)
iscolor = scolor (mod(is,maxscolor+1))
end if
return
end
c-----------------------------------------------------------------------
subroutine set_kmt_color(k, km, zw)
c
c set a GL color based on depth [either k or zw(k)]
c
#include "glstuff.h"
dimension zw(km)
c
if (k .ne. 0) then
#if defined kmt_colors || !defined depth_colors
call cpack(iscolor(real(k), 0.0, real(km), maxscolor,0))
#else
call cpack(iscolor(-zw(k), -zw(km), 0.0, 0, maxscolor))
#endif
else
call RGBcol(255,255,255)
end if
c
return
end
c-----------------------------------------------------------------------
subroutine waitmouse
c
c wait for any mouse button click
c left mouse button sets logical "leftmouse"
c middle mouse button sets logical "middlemouse"
c right mouse button sets logical "rightmouse"
c the other mouse logicals are set to false
c screen pixel coordinates of cursor are returned in (mx, my)
c icurrentwin has sgi window number (not makewindow number)
c
#include "fdevice.h"
#include "fgl.h"
c#include "fget.h"
#include "glstuff.h"
integer * 2 data
call qreset
leftmouse = .false.
middlemouse = .false.
rightmouse = .false.
999 continue
idev = qtest()
if (idev .eq. 0) goto 999
888 continue
idev = qread (data)
#ifdef debug_mouse2
print *, 'idev=',idev, ' data=',data
#endif
if (idev .eq. MOUSEX) then
mx = data
#ifdef debug_mouse2
print '(a,i4,a,i4,a)', 'MOUSE = (', mx,',',my,')'
#endif
else if (idev .eq. MOUSEY) then
my = data
#ifdef debug_mouse2
print '(a,i4,a,i4,a)', 'MOUSE = (', mx,',',my,')'
#endif
else if (idev .eq. LEFTMO .and. data .eq. 1) then
leftmouse = .true.
#ifdef debug_mouse
print *, 'LEFT MOUSE'
#endif
else if (idev .eq. MIDDLE .and. data .eq. 1) then
middlemouse = .true.
#ifdef debug_mouse
print *, 'MIDDLE MOUSE'
#endif
else if (idev .eq. RIGHTM .and. data .eq. 1) then
rightmouse = .true.
#ifdef debug_mouse
print *, 'RIGHT MOUSE'
#endif
else if (idev .eq. INPTCH) then
icurrentwin = data
#ifdef debug_mouse
print '(a,i4)', 'Entered window ',icurrentwin
#endif
end if
if (.not. (leftmouse .or. middlemouse .or. rightmouse)) goto 999
call qreset
return
end
c-----------------------------------------------------------------------
subroutine sensemouse
c
c Senses if one or more mouse buttons have been pressed.
c Flips all mouse buttons which have been pressed.
c Returns which mouse buttons have been pressed, but only after
c all pressed buttons are released.
c
#include "fdevice.h"
#include "fgl.h"
c#include "fget.h"
#include "glstuff.h"
integer * 2 data
logical leftmouse_released, middlemouse_released
logical rightmouse_released
logical leftmouse_pressed, middlemouse_pressed
logical rightmouse_pressed
leftmouse_pressed = .false.
middlemouse_pressed = .false.
rightmouse_pressed = .false.
leftmouse_released = .false.
middlemouse_released = .false.
rightmouse_released = .false.
c ***** THIS SUBROUTINE HAS BEEN FIXED BUT NOT TESTED *****
#define stopmouse_OK
#ifdef stopmouse_OK
999 continue
idev = qtest ()
if (idev .ne. 0) then
idev = qread (data)
if (idev .eq. RIGHTM) then
if (data .eq. 1) then
rightmouse_pressed = .true.
rightmouse = .not. rightmouse
else if (rightmouse) then
rightmouse_released = .true.
end if
else if (idev .eq. MIDDLE) then
if (data .eq. 1) then
middlemouse_pressed = .true.
middlemouse = .not. middlemouse
else if (middlemouse) then
middlemouse_released = .true.
end if
else if (idev .eq. LEFTMO) then
if (data .eq. 1) then
leftmouse_pressed = .true.
leftmouse = .not. leftmouse
else if (leftmouse) then
leftmouse_released = .true.
end if
end if
c goto 999
else
c
c there is nothing in the event queue
c if a mouse button has been pushed, wait for it to be released
c
if (leftmouse_pressed .and. .not. leftmouse_released) then
goto 999
end if
if (middlemouse_pressed .and. .not. middlemouse_released) then
goto 999
end if
if (rightmouse_pressed .and. .not. rightmouse_released) then
goto 999
end if
end if
#endif
return
end
c-----------------------------------------------------------------------
subroutine makewindow (iwinnr, title, icolor, pref,
& x1, x2, y1, y2,
& ix1, ix2, iy1, iy2)
#include "size.h"
#include "glstuff.h"
character * 32 title
character * 6 pref
integer*4 winope
nrwindows = max(iwinnr, nrwindows)
iwd(iwinnr) = ix2-ix1+1
iht(iwinnr) = iy2-iy1+1
if (pref .eq. 'prefpo') then
call prefpo (ix1, ix2, iy1, iy2)
else
call prefsi (iwd(iwinnr), iht(iwinnr))
end if
win_name(iwinnr) = title
iwin(iwinnr) = winope(title, len_trim(title))
call wintit(title, len_trim(title))
xl(iwinnr)=x1
xr(iwinnr)=x2
yl(iwinnr)=y1
yr(iwinnr)=y2
call ortho2 (xl(iwinnr), xr(iwinnr), yl(iwinnr), yr(iwinnr))
c I need real*4 arguments to ortho--since xl, xr, yl, yr are
c declared real*4, this trick keeps them as real*4, even when the
c compiler directive -r8 is invoked
call RGBmod
call gconfi
call cpack(icolor)
call clear
c
#ifdef debug_glstuff
print '(a,i2,a,i2,a,a)',
& 'tp: made window ',iwinnr,'-->',iwin(iwinnr),
& ' title: ',title
#endif
c
return
end
c-----------------------------------------------------------------------
subroutine scale_map (iwinnr,title,xu1,yu1,zw1, imt2, jmt2, km2)
c
c choose an appropriate orthogonal projection for a map window
c based on mom grid.
c
#include "size.h"
#include "glstuff.h"
character *(*) title
dimension xu1(imt), yu1(jmt), zw1(km)
dimension xu(0:imt), yu(0:jmt), zw(0:km)
call size_check (imt2, jmt2, km2, 'scale_main', 'fix_size')
call make_xyz0(xu1, yu1, zw1, xu, yu, zw)
c
#ifdef debug_glstuff
print *, 'tp: scale_map: iwinnr=',iwinnr
print *, 'tp: iwin(iwinnr)=', iwin(iwinnr)
#endif
c
call winset (iwin(iwinnr))
call wintit (title, len_trim(title))
c
c Check to see if highest longitudes exceed 360 degrees.
c Change boundaries of main map to compensate.
c
if (xu(imt) .gt. 360.0) then
xl(iwinnr)=xu(imt) - 360.0
xr(iwinnr)=xu(imt)
yl(iwinnr)=yl(imainmap)
yr(iwinnr)=yr(imainmap)
end if
c
c Check to see if limited area simulation is less than half the
c globe in latitude or longitude. If so, enlarge, preserving shape.
c
xscale = (xu(imt) - xu(0)) / 360.0
yscale = (yu(jmt) - yu(0)) / 180.0
xyscale = 1.00 * max(xscale, yscale)
if (xscale .lt. 0.5 .or. yscale .lt. 0.5 .or. .true.) then
xc = 0.5 * (xu(0) + xu(imt))
yc = 0.5 * (yu(0) + yu(jmt))
xl(iwinnr) = xc - 180.0 * xyscale
xr(iwinnr) = xc + 180.0 * xyscale
yl(iwinnr) = yc - 90.0 * xyscale
yr(iwinnr) = yc + 90.0 * xyscale
end if
c
c remap selected map window
c
call ortho2(xl(iwinnr),xr(iwinnr),yl(iwinnr),yr(iwinnr))
call RGBmod
call gconfi
call RGBcol (128, 128, 128)
call clear
c
#ifdef debug_glstuff
c tp:
c
print *, 'xl,xr,yl,yr=',
& xl(iwinnr),xr(iwinnr),yl(iwinnr),yr(iwinnr)
#endif
c
return
end
c-----------------------------------------------------------------------
subroutine clear_edit_window
#include "glstuff.h"
character *32 opt2
real*4 xm, ym
c
c clear edit window
c
call winset(iwin(izoom))
call wintit(' ', 1)
call cpack(iwhite)
call clear
call cpack(ired)
call cmov2((xl(izoom)+xr(izoom))/2, (yl(izoom)+yr(izoom))/2)
call charst('done', 4)
c
c clear mouse prompt window
c
call winset(iwin(iprompt))
call wintit(' ', 1)
call cpack(iwhite)
call clear
scale_factor = 32.0
call RGBcol (200, 0, 100)
opt2 = 'click any button to continue'
xm = 2-len_trim(opt2)/scale_factor
ym = -0.2
call cmov2(xm, ym)
call charst(opt2, len_trim(opt2))
c
c clear quit free edit window
c
call winset(iwin(iquit))
call wintit(' ', 1)
call cpack(iwhite)
call clear
c
call winset(iwin(izoom))
return
end
c-----------------------------------------------------------------------
subroutine gl_announce_phase(title)
#include "glstuff.h"
character *(*) title
character *32 title2
c
c change title on main map window
c
call winset(iwin(imainmap))
title2 = title
call wintit(title2, len_trim(title2))
call winset(iwin(izoom))
return
end
c-----------------------------------------------------------------------
subroutine show_iter (iter, title)
#include "glstuff.h"
#include "size.h"
character *6 str_iter, title2
character *(*) title
real*4 xm, ym
c call sensemouse
call winset (iwin(iterwin))
title2 = title
call wintit(title2, len_trim(title2))
call RGBcol (250, 250, 0)
it = nint(real(iter)/imt * maxscolor)
call cpack (scolor(min(it, maxscolor)))
call clear
call RGBcol (0, 0, 0)
write (str_iter, '(i6)') iter
call cmov2i (12,8)
xm = -0.4
ym = -0.2
call cmov2 (xm, ym)
call charst (str_iter, len_trim(str_iter))
call winset (iwin(imainmap))
return
end
c-----------------------------------------------------------------------
subroutine display_vector (vec,title,amax,window)
c
c displays a 2-dimensional field of real values.
c using a balanced scalar plot scaled from -amax <= v <= amax
c window must be scaled for latitude and longitude using ortho2.
c
c inputs:
c vec = the field to display
c title = title to write to window frame
c amax = maximum absolute value used for scaling colors
c iwinnr= window number [assigned by makewindow]
#include "size.h"
#include "glstuff.h"
character *(*) title, window
dimension vec (imt,jmt)
do iwinnr=1,min(nrwindows, maxwindows)
if (window .eq. win_name(iwinnr)) then
call display_vec(vec,title,1.0,amax,'b',iwinnr)
end if
end do
return
end
c-----------------------------------------------------------------------
subroutine display_vec (vec,title,amin,amax,mode,iwinnr)
c
c displays a 2-dimensional field of real values.
c window must be scaled for latitude and longitude using ortho2.
c
c inputs:
c vec = the field to display
c title = title to write to window frame
c amin = minimum absolute value used for scaling colors
c amax = maximum absolute value used for scaling colors
c mode = 's' : scalar plot scaled from amin <= v <= amax
c = 'b' : scalar plot scaled from -amax <= v <= amax
c = 'l' : log plot scaled from ln(amin) <= ln(v) <= ln(amax)
c color reversed modes
c = 'S' : scalar plot scaled from amin <= v <= amax
c = 'B' : scalar plot scaled from -amax <= v <= amax
c iwinnr= window number [assigned by makewindow]
c xu = longitude of u/v points
c yu = latitude of u/v points
#include "size.h"
#include "coord.h"
#include "glstuff.h"
character *(*) title
character *(*) mode
dimension vec (imt,jmt)
dimension xu0(0:imt), yu0(0:jmt), zw0(0:km)
real *4 x1, y1, x2, y2
call sensemouse
if (middlemouse) return
call make_xyz0(xu, yu, zw, xu0, yu0, zw0)
call winset (iwin(iwinnr))
call wintit (title, len_trim(title))
do i=1,imt
do j=jmt,1,-1
if (mode .eq. 's') then
icolor = iscolor (vec(i,j), amin, amax, 0, maxscolor)
else if (mode .eq. 'b') then
icolor = iscolor (vec(i,j), -amax, amax, 0, maxscolor)
else if (mode .eq. 'l') then
icolor = ilcolor (vec(i,j), amin, amax, 0, maxscolor)
else if (mode .eq. 'S') then
icolor = iscolor (vec(i,j), amin, amax, maxscolor, 0)
else if (mode .eq. 'B') then
icolor = iscolor (vec(i,j), -amax, amax, maxscolor, 0)
else
icolor = iscolor (vec(i,j), amin, amax, 0, maxscolor)
end if
call cpack(icolor)
call gl_rectf(xu0(i-1), yu0(j-1), xu0(i), yu0(j))
end do
end do
call winset (iwin(imainmap))
return
end
c-----------------------------------------------------------------------
subroutine gl_rectf(x1, y1, x2, y2)
c
c filled rectangle to work with real*8 [-r8] or real*4 arguments
c
real *4 x1_gl, y1_gl, x2_gl, y2_gl
x1_gl = x1
x2_gl = x2
y1_gl = y1
y2_gl = y2
call rectf(x1_gl, y1_gl, x2_gl, y2_gl)
return
end
c-----------------------------------------------------------------------
subroutine gl_rect(x1, y1, x2, y2)
c
c rectangle to work with real*8 [-r8] or real*4 arguments
c
real *4 x1_gl, y1_gl, x2_gl, y2_gl
x1_gl = x1
x2_gl = x2
y1_gl = y1
y2_gl = y2
call rect(x1_gl, y1_gl, x2_gl, y2_gl)
return
end
c-----------------------------------------------------------------------
subroutine display_vec_3x3 (vec,title,amax,iwinnr)
c
c displays NE quadrants of a 2-dimensional field of 3x3 arrays
c of real values. [like cf(imt,jmt,-1:1,-1:1)]
c window must be scaled for latitude and longitude using ortho2.
c
c inputs:
c vec = the field to display
c title = title to write to window frame
c amax = maximum absolute value used for scaling colors
c iwinnr= window number [assigned by makewindow]
c xu = longitude of u/v points
c yu = latitude of u/v points
#include "size.h"
#include "coord.h"
#include "glstuff.h"
character *(*) title
character *(*) mode
dimension vec (imt,jmt,-1:1,-1:1)
dimension xu0(0:imt), yu0(0:jmt), zw0(0:km)
real *4 x1,x2,y1,y2
call sensemouse
if (middlemouse) return
call make_xyz0(xu, yu, zw, xu0, yu0, zw0)
call winset (iwin(iwinnr))
call cpack(iwhite)
call clear
call wintit (title, len_trim(title))
do i=1,imt
do j=jmt,1,-1
do i1=-1,1
do j1=-1,1
icolor = iscolor(vec(i,j,i1,j1),-amax,amax,0,maxscolor)
call cpack(icolor)
x1 = 0.5*(xu0(i-1)+xu0(i))+(i1 )*(xu0(i)-xu0(i-1)) / 4.0
x2 = 0.5*(xu0(i-1)+xu0(i))+(i1+1)*(xu0(i)-xu0(i-1)) / 4.0
y1 = 0.5*(yu0(j-1)+yu0(j))+(j1 )*(yu0(j)-yu0(j-1)) / 4.0
y2 = 0.5*(yu0(j-1)+yu0(j))+(j1+1)*(yu0(j)-yu0(j-1)) / 4.0
call rectf(x1, y1, x2, y2)
end do
end do
end do
end do
call winset (iwin(imainmap))
return
end
c-----------------------------------------------------------------------
subroutine display_grid (title, xu1, yu1, zw1, imt2, jmt2, km2)
#include "size.h"
#include "glstuff.h"
character *(*) title
character *32 title2
dimension xu1(imt), yu1(jmt), zw1(km)
dimension xu(0:imt), yu(0:jmt), zw(0:km)
real*4 p(2), zmax
character * 4 si
call size_check (imt2, jmt2, km2, 'display_grid', 'fix_size')
call make_xyz0(xu1, yu1, zw1, xu, yu, zw)
call winset (iwin(imainmap))
call wintit (title, len_trim(title))
call RGBcol (200, 200, 200)
call subpix(.true.)
igrid_space=5
do i=1,imt,igrid_space
call bgnlin
p(1)=xu(i)
p(2)=yu(1)
call v2f(p)
p(1)=xu(i)
p(2)=yu(jmt)
call v2f(p)
call endlin
end do
do j=1,jmt,igrid_space
call bgnlin
p(1)=xu(1)
p(2)=yu(j)
call v2f(p)
p(1)=xu(imt)
p(2)=yu(j)
call v2f(p)
call endlin
end do
c
c print longitudes to window
c