File: cmapf1.0.f

package info (click to toggle)
flextra 5.0-2.1
  • links: PTS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 860 kB
  • ctags: 402
  • sloc: fortran: 6,987; makefile: 55; sh: 17
file content (707 lines) | stat: -rw-r--r-- 24,987 bytes parent folder | download | duplicates (7)
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
C CHANGES TO THE ROUTINES BY A. STOHL
C XI,XI0,ETA,ETA0 ARE DOUBLE PRECISION VARIABLES TO AVOID PROBLEMS
C AT POLES

	SUBROUTINE CC2GLL (STRCMP, XLAT,XLONG, UE,VN, UG,VG)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	DOUBLE PRECISION XPOLG,YPOLG,ALONG,SLONG,CLONG,ROT
	REAL STRCMP(9)
	ALONG = CSPANF( XLONG - STRCMP(2), -180., 180.)
	IF (XLAT.GT.89.985) THEN
C*  NORTH POLAR METEOROLOGICAL ORIENTATION: "NORTH" ALONG PRIME MERIDIAN
	  ROT = - STRCMP(1) * ALONG + XLONG - 180.
	ELSEIF (XLAT.LT.-89.985) THEN
C*  SOUTH POLAR METEOROLOGICAL ORIENTATION: "NORTH" ALONG PRIME MERIDIAN
	  ROT = - STRCMP(1) * ALONG - XLONG
	ELSE
	  ROT = - STRCMP(1) * ALONG
	ENDIF
	SLONG = SIN( RADPDG * ROT )
	CLONG = COS( RADPDG * ROT )
	XPOLG = SLONG * STRCMP(5) + CLONG * STRCMP(6)
	YPOLG = CLONG * STRCMP(5) - SLONG * STRCMP(6)
	UG = YPOLG * UE + XPOLG * VN
	VG = YPOLG * VN - XPOLG * UE
	RETURN
	END

	SUBROUTINE CCRVLL (STRCMP, XLAT,XLONG, GX,GY)
C*  WRITTEN ON 9/20/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (REARTH=6 371.2)
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	DOUBLE PRECISION XPOLG,YPOLG,TEMP,ALONG,SLONG,CLONG,CTEMP
	REAL STRCMP(9)
	ALONG = CSPANF( XLONG - STRCMP(2), -180., 180.)
	SLONG = SIN( RADPDG * STRCMP(1) * ALONG)
	CLONG = COS( RADPDG * STRCMP(1) * ALONG)
	XPOLG = - SLONG * STRCMP(5) + CLONG * STRCMP(6)
	YPOLG = CLONG * STRCMP(5) + SLONG * STRCMP(6)
        TEMP = SIN(RADPDG * XLAT)
        CTEMP = COS(RADPDG * XLAT)
        CURV = (STRCMP(1) - TEMP) / CTEMP / REARTH
        GX = CURV * XPOLG
        GY = CURV * YPOLG
	RETURN
	END

	SUBROUTINE CCRVXY (STRCMP, X,Y, GX,GY)
C*  WRITTEN ON 9/20/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (REARTH=6 371.2)
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	REAL STRCMP(9)
	DOUBLE PRECISION XPOLG,YPOLG,TEMP,YMERC,EFACT,CURV
	TEMP = STRCMP(1) * STRCMP(7) /REARTH
	XPOLG = STRCMP(6) + TEMP * (STRCMP(3) - X)
	YPOLG = STRCMP(5) + TEMP * (STRCMP(4) - Y)
	TEMP = SQRT ( XPOLG ** 2 + YPOLG ** 2 )
	IF (TEMP.GT.0.) THEN
	  YMERC = - LOG( TEMP) /STRCMP(1)
	  EFACT = EXP(YMERC)
 	  CURV = ( (STRCMP(1) - 1.D0) * EFACT +
     A            (STRCMP(1) + 1.D0) / EFACT )
     B           * .5D0 / REARTH
	  GX = XPOLG * CURV / TEMP
	  GY = YPOLG * CURV / TEMP
	ELSE
	  IF (ABS(STRCMP(1)) .EQ. 1.) THEN
	    GX = 0.
	    GY = 0.
	  ELSE
	    GX = 1./REARTH
	    GY = 1./REARTH
	  ENDIF
	ENDIF
	RETURN
	END

	SUBROUTINE CG2CLL (STRCMP, XLAT,XLONG, UG,VG, UE,VN)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	DOUBLE PRECISION XPOLG,YPOLG,ALONG,SLONG,CLONG,ROT
	REAL STRCMP(9)
	ALONG = CSPANF( XLONG - STRCMP(2), -180., 180.)
	IF (XLAT.GT.89.985) THEN
C*  NORTH POLAR METEOROLOGICAL ORIENTATION: "NORTH" ALONG PRIME MERIDIAN
	  ROT = - STRCMP(1) * ALONG + XLONG - 180.
	ELSEIF (XLAT.LT.-89.985) THEN
C*  SOUTH POLAR METEOROLOGICAL ORIENTATION: "NORTH" ALONG PRIME MERIDIAN
	  ROT = - STRCMP(1) * ALONG - XLONG
	ELSE
	  ROT = - STRCMP(1) * ALONG
	ENDIF
	SLONG = SIN( RADPDG * ROT )
	CLONG = COS( RADPDG * ROT )
	XPOLG = SLONG * STRCMP(5) + CLONG * STRCMP(6)
	YPOLG = CLONG * STRCMP(5) - SLONG * STRCMP(6)
	UE = YPOLG * UG - XPOLG * VG
	VN = YPOLG * VG + XPOLG * UG
	RETURN
	END

	SUBROUTINE CG2CXY (STRCMP, X,Y, UG,VG, UE,VN)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (REARTH=6 371.2)
	REAL STRCMP(9)
	DOUBLE PRECISION XPOLG,YPOLG,TEMP,XI0,ETA0,XI,ETA
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	XI0 = ( X - STRCMP(3) ) * STRCMP(7) / REARTH
	ETA0 = ( Y - STRCMP(4) ) * STRCMP(7) /REARTH
	XI = XI0 * STRCMP(5) - ETA0 * STRCMP(6)
	ETA = ETA0 * STRCMP(5) + XI0 * STRCMP(6)
	RADIAL = 2. * ETA - STRCMP(1) * (XI*XI + ETA*ETA)
	IF (RADIAL.GT.STRCMP(8)) THEN
C*  CASE NORTH OF 89 DEGREES.  METEOROLOGICAL WIND DIRECTION DEFINITION
C*      CHANGES.
	  CALL CNXYLL(STRCMP, XI,ETA, XLAT,XLONG) 
C*  NORTH POLAR METEOROLOGICAL ORIENTATION: "NORTH" ALONG PRIME MERIDIAN
	  ROT = STRCMP(1) * (XLONG - STRCMP(2)) - XLONG - 180.
	  SLONG = - SIN( RADPDG * ROT )
	  CLONG = COS( RADPDG * ROT )
	  XPOLG = SLONG * STRCMP(5) + CLONG * STRCMP(6)
	  YPOLG = CLONG * STRCMP(5) - SLONG * STRCMP(6)
	ELSE IF (RADIAL.LT.STRCMP(9)) THEN
C*  CASE SOUTH OF -89 DEGREES.  METEOROLOGICAL WIND DIRECTION DEFINITION
C*      CHANGES.
	  CALL CNXYLL(STRCMP, XI,ETA, XLAT,XLONG) 
C*  SOUTH POLAR METEOROLOGICAL ORIENTATION: "NORTH" ALONG PRIME MERIDIAN
	  ROT = STRCMP(1) * (XLONG - STRCMP(2)) + XLONG
	  SLONG = - SIN( RADPDG * ROT )
	  CLONG = COS( RADPDG * ROT )
	  XPOLG = SLONG * STRCMP(5) + CLONG * STRCMP(6)
	  YPOLG = CLONG * STRCMP(5) - SLONG * STRCMP(6)
	ELSE
C* NORMAL CASE.  METEOROLOGICAL DIRECTION OF WIND RELATED TO TRUE NORTH.
	  XPOLG = STRCMP(6) - STRCMP(1) * XI0
	  YPOLG = STRCMP(5) - STRCMP(1) * ETA0
	  TEMP = SQRT ( XPOLG ** 2 + YPOLG ** 2 )
	  XPOLG = XPOLG / TEMP
	  YPOLG = YPOLG / TEMP
	END IF
	UE = ( YPOLG * UG - XPOLG * VG )
	VN = ( YPOLG * VG + XPOLG * UG )
	RETURN
	END

	REAL FUNCTION CGSZLL (STRCMP, XLAT,XLONG)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180D0/PI)
	REAL STRCMP(9)
	DOUBLE PRECISION SLAT,YMERC,EFACT
	IF (XLAT .GT. 89.985) THEN
C* CLOSE TO NORTH POLE
	  IF (STRCMP(1) .GT. 0.9999) THEN
C* AND TO GAMMA == 1.
	    CGSZLL = 2. * STRCMP(7)
	    RETURN
	  ENDIF
	  EFACT = COS(RADPDG * XLAT)
	  IF (EFACT .LE. 0.) THEN
	    CGSZLL = 0.
	    RETURN
	  ELSE
	    YMERC = - LOG( EFACT /(1. + SIN(RADPDG * XLAT)))
	  ENDIF
	ELSE IF (XLAT .LT. -89.985) THEN
C* CLOSE TO SOUTH POLE
	  IF (STRCMP(1) .LT. -0.9999) THEN
C* AND TO GAMMA == -1.0
	    CGSZLL = 2. * STRCMP(7)
	    RETURN
	  ENDIF
	  EFACT = COS(RADPDG * XLAT)
	  IF (EFACT .LE. 0.) THEN
	    CGSZLL = 0.
	    RETURN
	  ELSE
	    YMERC = LOG( EFACT /(1. - SIN(RADPDG * XLAT)))
	  ENDIF
	ELSE
	SLAT = SIN(RADPDG * XLAT)
	YMERC = LOG((1. + SLAT) / (1. - SLAT))/2.
C	EFACT = EXP(YMERC)
C	CGSZLL = 2. * STRCMP(7) * EXP (STRCMP(1) * YMERC)
C     C			 / (EFACT + 1./EFACT)
	ENDIF
	CGSZLL = STRCMP(7) * COS(RADPDG * XLAT) * EXP(STRCMP(1) *YMERC)
	RETURN
	END

	REAL FUNCTION CGSZXY (STRCMP, X,Y)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (REARTH=6 371.2,ALMST1=.9999999)
	REAL STRCMP(9)
	DOUBLE PRECISION YMERC,EFACT
	DOUBLE PRECISION XI0,ETA0,XI,ETA
	XI0 = ( X - STRCMP(3) ) * STRCMP(7) / REARTH
	ETA0 = ( Y - STRCMP(4) ) * STRCMP(7) /REARTH
	XI = XI0 * STRCMP(5) - ETA0 * STRCMP(6)
	ETA = ETA0 * STRCMP(5) + XI0 * STRCMP(6)
	RADIAL = 2. * ETA - STRCMP(1) * (XI*XI + ETA*ETA)
	EFACT = STRCMP(1) * RADIAL
	IF (EFACT .GT. ALMST1) THEN
	  IF (STRCMP(1).GT.ALMST1) THEN
	    CGSZXY = 2. * STRCMP(7)
	  ELSE
	    CGSZXY = 0.
	  ENDIF
	  RETURN
	ENDIF
	IF (ABS(EFACT) .LT. 1.E-2) THEN
	  TEMP = (EFACT / (2. - EFACT) )**2
	  YMERC = RADIAL / (2. - EFACT) * (1.    + TEMP *
     C				          (1./3. + TEMP *
     C				          (1./5. + TEMP *
     C				          (1./7. ))))
	ELSE
	  YMERC = - LOG( 1. - EFACT ) /2. /STRCMP(1)
	ENDIF
	IF (YMERC .GT. 6.) THEN
	  IF (STRCMP(1) .GT. ALMST1) THEN
	    CGSZXY = 2. * STRCMP(7)
	  ELSE
	    CGSZXY = 0.
	  ENDIF
	ELSE IF (YMERC .LT. -6.) THEN
	  IF (STRCMP(1) .LT. -ALMST1) THEN
	    CGSZXY = 2. * STRCMP(7)
	  ELSE
	    CGSZXY = 0.
	  ENDIF
	ELSE
	  EFACT = EXP(YMERC)
	  CGSZXY = 2. * STRCMP(7) * EXP (STRCMP(1) * YMERC)
     C				 / (EFACT + 1./EFACT)
	ENDIF
	RETURN
	END

	SUBROUTINE CLL2XY (STRCMP, XLAT,XLONG, X,Y)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (REARTH=6 371.2)
	REAL STRCMP(9)
	CALL CNLLXY(STRCMP, XLAT,XLONG, XI,ETA)
	X = STRCMP(3) + REARTH/STRCMP(7) *
     C		 (XI * STRCMP(5) + ETA * STRCMP(6) )
	Y = STRCMP(4) + REARTH/STRCMP(7) *
     C		 (ETA * STRCMP(5) - XI * STRCMP(6) )
	RETURN
	END

	SUBROUTINE CNLLXY (STRCMP, XLAT,XLONG, XI,ETA)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
C  MAIN TRANSFORMATION ROUTINE FROM LATITUDE-LONGITUDE TO
C  CANONICAL (EQUATOR-CENTERED, RADIAN UNIT) COORDINATES
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	PARAMETER (ALMST1=.9999999)
	REAL STRCMP(9)
 	DOUBLE PRECISION GAMMA
	DOUBLE PRECISION DLONG,DLAT,SLAT,MERCY,GMERCY
	GAMMA = STRCMP(1)
	DLAT = XLAT
	DLONG = CSPANF(XLONG - STRCMP(2), -180., 180.)
	DLONG = DLONG * RADPDG
	GDLONG = GAMMA * DLONG
	IF (ABS(GDLONG) .LT. .01) THEN
C  CODE FOR GAMMA SMALL OR ZERO.  THIS AVOIDS ROUND-OFF ERROR OR DIVIDE-
C  BY ZERO IN THE CASE OF MERCATOR OR NEAR-MERCATOR PROJECTIONS.
	  GDLONG = GDLONG * GDLONG
	  SNDGAM = DLONG * (1. - 1./6. * GDLONG *
     C			   (1. - 1./20. * GDLONG *
     C			   (1. - 1./42. * GDLONG )))
	  CSDGAM = DLONG * DLONG * .5 *
     C			   (1. - 1./12. * GDLONG *
     C			   (1. - 1./30. * GDLONG * 
     C			   (1. - 1./56. * GDLONG )))
	ELSE
C CODE FOR MODERATE VALUES OF GAMMA
	  SNDGAM = SIN (GDLONG) /GAMMA
	  CSDGAM = (1. - COS(GDLONG) )/GAMMA /GAMMA
	ENDIF
	SLAT = SIN(RADPDG * DLAT)
	IF ((SLAT .GE. ALMST1) .OR. (SLAT .LE. -ALMST1)) THEN
	  ETA = 1./STRCMP(1)
	  XI = 0.
	  RETURN
	ENDIF
	MERCY = .5 * LOG( (1. + SLAT) / (1. - SLAT) )
	GMERCY = GAMMA * MERCY
	IF (ABS(GMERCY) .LT. .001) THEN
C  CODE FOR GAMMA SMALL OR ZERO.  THIS AVOIDS ROUND-OFF ERROR OR DIVIDE-
C  BY ZERO IN THE CASE OF MERCATOR OR NEAR-MERCATOR PROJECTIONS.
	  RHOG1 = MERCY * (1. - .5 * GMERCY *
     C			  (1. - 1./3. * GMERCY *
     C			  (1. - 1./4. * GMERCY ) ) )
	ELSE
C CODE FOR MODERATE VALUES OF GAMMA
	  RHOG1 = (1. - EXP(-GMERCY)) / GAMMA
	ENDIF
	ETA = RHOG1 + (1. - GAMMA * RHOG1) * GAMMA * CSDGAM
	XI = (1. - GAMMA * RHOG1 ) * SNDGAM
	END

	SUBROUTINE CNXYLL (STRCMP, XI,ETA, XLAT,XLONG)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
C  MAIN TRANSFORMATION ROUTINE FROM CANONICAL (EQUATOR-CENTERED,
C  RADIAN UNIT) COORDINATES
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	PARAMETER (ALMST1=.9999999)
	REAL STRCMP(9)
	DOUBLE PRECISION GAMMA,TEMP,ARG1,ARG2,YMERC,ALONG,GXI,CGETA
        DOUBLE PRECISION XI,ETA
	GAMMA = STRCMP(1)
C  CALCULATE EQUIVALENT MERCATOR COORDINATE
	ODIST = XI*XI + ETA*ETA
	ARG2 = 2. * ETA - GAMMA * (XI*XI + ETA*ETA)
	ARG1 = GAMMA * ARG2
C Change by A. Stohl to avoid problems close to the poles
C IF (ARG1 .GE. ALMST1) THEN
C  DISTANCE TO NORTH (OR SOUTH) POLE IS ZERO (OR IMAGINARY ;) )
C XLAT = SIGN(90.,STRCMP(1))
C XLONG = STRCMP(2)
C RETURN
C ENDIF
	IF (ABS(ARG1) .LT. .01) THEN
C  CODE FOR GAMMA SMALL OR ZERO.  THIS AVOIDS ROUND-OFF ERROR OR DIVIDE-
C  BY ZERO IN THE CASE OF MERCATOR OR NEAR-MERCATOR PROJECTIONS.
	  TEMP = (ARG1 / (2. - ARG1) )**2
	  YMERC = ARG2 / (2. - ARG1) * (1.    + TEMP *
     C				       (1./3. + TEMP *
     C				       (1./5. + TEMP *
     C				       (1./7. ))))
	ELSE
C CODE FOR MODERATE VALUES OF GAMMA
	  YMERC = - LOG ( 1. - ARG1 ) /2. / GAMMA
	ENDIF
C  CONVERT YMERC TO LATITUDE
	TEMP = EXP( - ABS(YMERC) )
	XLAT = SIGN(ATAN2((1. - TEMP) * (1. + TEMP), 2. * TEMP), YMERC)
C  FIND LONGITUDES
	GXI = GAMMA*XI
	CGETA = 1. - GAMMA * ETA
	IF ( ABS(GXI) .LT. .01*CGETA ) THEN
C  CODE FOR GAMMA SMALL OR ZERO.  THIS AVOIDS ROUND-OFF ERROR OR DIVIDE-
C  BY ZERO IN THE CASE OF MERCATOR OR NEAR-MERCATOR PROJECTIONS.
	  TEMP = ( GXI /CGETA )**2
	  ALONG = XI / CGETA * (1.    - TEMP *
     C			       (1./3. - TEMP *
     C			       (1./5. - TEMP *
     C			       (1./7.   ))))
	ELSE
C CODE FOR MODERATE VALUES OF GAMMA
	  ALONG = ATAN2( GXI, CGETA) / GAMMA
	ENDIF
	XLONG = SNGL(STRCMP(2) + DGPRAD * ALONG)
	XLAT = XLAT * DGPRAD
	RETURN
	END

	SUBROUTINE CPOLLL (STRCMP, XLAT,XLONG, ENX,ENY,ENZ)
C*  WRITTEN ON 11/23/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180.,DGPRAD=180./PI)
	DOUBLE PRECISION XPOLG,YPOLG,ALONG,SLONG,CLONG,ROT
	REAL STRCMP(9)
	ALONG = CSPANF( XLONG - STRCMP(2), -180., 180.)
	  ROT = - STRCMP(1) * ALONG
	SLONG = SIN( RADPDG * ROT )
	CLONG = COS( RADPDG * ROT )
	XPOLG = SLONG * STRCMP(5) + CLONG * STRCMP(6)
	YPOLG = CLONG * STRCMP(5) - SLONG * STRCMP(6)
	CLAT = COS(RADPDG * XLAT)
	ENX = CLAT * XPOLG
	ENY = CLAT * YPOLG
	ENZ = SIN(RADPDG * XLAT)
	RETURN
	END

	SUBROUTINE CPOLXY (STRCMP, X,Y, ENX,ENY,ENZ)
C*  WRITTEN ON 11/26/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (REARTH=6 371.2)
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	REAL STRCMP(9)
	DOUBLE PRECISION XPOL,YPOL,TEMP,XI0,ETA0,XI,ETA,RADIAL
	DOUBLE PRECISION TEMP2,YMERC,ARG,OARG,CLAT
	XI0 = ( X - STRCMP(3) ) * STRCMP(7) / REARTH
	ETA0 = ( Y - STRCMP(4) ) * STRCMP(7) /REARTH
	XI = XI0 * STRCMP(5) - ETA0 * STRCMP(6)
	ETA = ETA0 * STRCMP(5) + XI0 * STRCMP(6)
	RADIAL = 2. * ETA -  STRCMP(1) * (XI*XI + ETA*ETA)
	TEMP = STRCMP(1) * RADIAL
	IF (TEMP .GE. 1.) THEN
	  ENX = 0.
	  ENY = 0.
	  ENZ = SIGN(1.,STRCMP(1))
	  RETURN
	ENDIF
	IF (ABS(TEMP).LT.1.E-2) THEN
	  TEMP2 = (TEMP / (2. - TEMP))**2
	  YMERC = RADIAL / (2. - TEMP) * (1. + TEMP2 *
     C					 (1./3. + TEMP2 *
     C					 (1./5. + TEMP2 *
     C					 (1./7.))))
	ELSE
	  YMERC = -.5 * LOG(1. - TEMP) / STRCMP(1)
	ENDIF
	ARG = EXP( YMERC )
	OARG = 1./ARG
	CLAT = 2./(ARG + OARG)
	ENZ = (ARG - OARG) * CLAT /2.
	TEMP = CLAT / SQRT(1. - TEMP)
	XPOL = - XI * STRCMP(1) * TEMP
	YPOL = (1. - ETA * STRCMP(1) ) * TEMP
	ENX = XPOL * STRCMP(5) + YPOL * STRCMP(6)
	ENY = YPOL * STRCMP(5) - XPOL * STRCMP(6)
	RETURN
	END

	REAL FUNCTION CSPANF (VALUE, BEGIN, END)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
C* REAL FUNCTION CSPANF RETURNS A VALUE IN THE INTERVAL (BEGIN,END]
C* WHICH IS EQUIVALENT TO VALUE, MOD (END - BEGIN).  IT IS USED TO
C* REDUCE PERIODIC VARIABLES TO A STANDARD RANGE.  IT ADJUSTS FOR THE
C* BEHAVIOR OF THE MOD FUNCTION WHICH PROVIDES POSITIVE RESULTS FOR
c* POSITIVE INPUT, AND NEGATIVE RESULTS FOR NEGATIVE INPUT
C* INPUT:
C*       VALUE - REAL NUMBER TO BE REDUCED TO THE SPAN
C*       BEGIN - FIRST VALUE OF THE SPAN
C*       END   - LAST VALUE OF THE SPAN
C* RETURNS:
C*       THE REDUCED VALUE
C* EXAMPLES:
C*      ALONG = CSPANF(XLONG, -180., +180.)
C*      DIR  = CSPANF(ANGLE, 0., 360.)
	REAL FIRST,LAST
	FIRST = MIN(BEGIN,END)
	LAST = MAX(BEGIN,END)
	VAL = MOD( VALUE - FIRST , LAST - FIRST)
	IF ( VAL . LE. 0.) THEN
	  CSPANF = VAL + LAST
	ELSE
	  CSPANF = VAL + FIRST
	ENDIF
	RETURN
	END

	SUBROUTINE CXY2LL (STRCMP, X,Y, XLAT,XLONG)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (REARTH=6 371.2)
        DOUBLE PRECISION XI0,ETA0,XI,ETA
	REAL STRCMP(9)
	XI0 = ( X - STRCMP(3) ) * STRCMP(7) / REARTH
	ETA0 = ( Y - STRCMP(4) ) * STRCMP(7) /REARTH
	XI = XI0 * STRCMP(5) - ETA0 * STRCMP(6)
	ETA = ETA0 * STRCMP(5) + XI0 * STRCMP(6)
	CALL CNXYLL(STRCMP, XI,ETA, XLAT,XLONG)
	XLONG = CSPANF(XLONG, -180., 180.)
	RETURN
	END

	REAL FUNCTION EQVLAT (XLAT1,XLAT2)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	SIND(X) = SIN (RADPDG*X)
	SINL1 = SIND (XLAT1)
	SINL2 = SIND (XLAT2)
	IF (ABS(SINL1 - SINL2) .GT. .001) THEN
	  AL1 = LOG((1. - SINL1)/(1. - SINL2))
	  AL2 = LOG((1. + SINL1)/(1. + SINL2))
	ELSE
C  CASE LAT1 NEAR OR EQUAL TO LAT2
	  TAU = - (SINL1 - SINL2)/(2. - SINL1 - SINL2)
	  TAU = TAU*TAU
	  AL1  = 2. / (2. - SINL1 - SINL2) * (1.    + TAU *
     C 					     (1./3. + TAU *
     C					     (1./5. + TAU *
     C					     (1./7.))))
	  TAU =   (SINL1 - SINL2)/(2. + SINL1 + SINL2)
	  TAU = TAU*TAU
	  AL2  = -2. / (2. + SINL1 + SINL2) * (1.    + TAU *
     C 					      (1./3. + TAU *
     C					      (1./5. + TAU *
     C					      (1./7.))))
	ENDIF
	EQVLAT = ASIN((AL1 + AL2) / (AL1 - AL2))/RADPDG
	RETURN
	END

	SUBROUTINE STCM1P(STRCMP, X1,Y1, XLAT1,XLONG1,
     C XLATG,XLONGG, GRIDSZ, ORIENT)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	REAL STRCMP(9)
	DO K=3,4
	  STRCMP (K) = 0.
	ENDDO
        TURN = RADPDG * (ORIENT - STRCMP(1) *
     C            CSPANF(XLONGG - STRCMP(2), -180., 180.) )
	STRCMP (5) = COS (TURN)
	STRCMP (6) = - SIN (TURN)
	STRCMP (7) = 1.
	STRCMP (7) = GRIDSZ * STRCMP(7)
     C             / CGSZLL(STRCMP, XLATG, STRCMP(2))
	CALL CLL2XY (STRCMP, XLAT1,XLONG1, X1A,Y1A)
	STRCMP(3) = STRCMP(3) + X1 - X1A
	STRCMP(4) = STRCMP(4) + Y1 - Y1A
	RETURN
	END

	SUBROUTINE STCM2P(STRCMP, X1,Y1, XLAT1,XLONG1,
     C X2,Y2, XLAT2,XLONG2)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	REAL STRCMP(9)
	DO K=3,6
	  STRCMP (K) = 0.
	ENDDO
	STRCMP (5) = 1.
	STRCMP (7) = 1.
	CALL CLL2XY (STRCMP, XLAT1,XLONG1, X1A,Y1A)
	CALL CLL2XY (STRCMP, XLAT2,XLONG2, X2A,Y2A)
	DEN = SQRT( (X1 - X2)**2 + (Y1 - Y2)**2 )
	DENA = SQRT( (X1A - X2A)**2 + (Y1A - Y2A)**2 )
	STRCMP(5) = ((X1A - X2A)*(X1 - X2) + (Y1A - Y2A) * (Y1 - Y2))
     C  /DEN /DENA
	STRCMP(6) = ((Y1A - Y2A)*(X1 - X2) - (X1A - X2A) * (Y1 - Y2))
     C  /DEN /DENA
	STRCMP (7) = STRCMP(7) * DENA / DEN
	CALL CLL2XY (STRCMP, XLAT1,XLONG1, X1A,Y1A)
	STRCMP(3) = STRCMP(3) + X1 - X1A
	STRCMP(4) = STRCMP(4) + Y1 - Y1A
	RETURN
	END

C*  GENERAL CONFORMAL MAP ROUTINES FOR METEOROLOGICAL MODELERS
C*  WRITTEN ON 3/31/94 BY

C* Dr. Albion Taylor
C* NOAA / OAR / ARL                  Phone: (301) 713-0295 x 132
C* Rm. 3151, 1315 East-West Highway  Fax:   (301) 713-0119
C* Silver Spring, MD 20910           E-mail: ADTaylor@arlrisc.ssmc.noaa.gov 

C*  SUBROUTINE STLMBR (STRCMP, TNGLAT, CLONG)
C*    THIS ROUTINE INITIALIZES THE MAP STRUCTURE ARRAY STRCMP TO
C*    THE FORM OF A SPECIFIC MAP PROJECTION
C*  INPUTS:
C*    TNGLAT - THE LATITUDE AT WHICH THE PROJECTION WILL BE TANGENT
C*             TO THE EARTH.  +90. FOR NORTH POLAR STEREOGRAPHIC,
C*             -90. FOR SOUTH POLAR STEREOGRAPHIC, 0. FOR MERCATOR,
C*             AND OTHER VALUES FOR LAMBERT CONFORMAL. 
C*             -90 <= TNGLAT <= 90.
C*    CLONG -  A LONGITUDE IN THE REGION UNDER CONSIDERATION.  LONGITUDES
C*             BETWEEN CLONG-180. AND CLONG+180.  WILL BE MAPPED IN ONE
C*             CONNECTED REGION
C*  OUTPUTS:
C*    STRCMP - A 9-VALUE MAP STRUCTURE ARRAY FOR USE WITH SUBSEQUENT
C*             CALLS TO THE COORDINATE TRANSFORM ROUTINES.
C*
C*  REAL FUNCTION EQVLAT (XLAT1,XLAT2)
C*    THIS FUNCTION IS PROVIDED TO ASSIST IN FINDING THE TANGENT LATITUDE
C*    EQUIVALENT TO THE 2-REFERENCE LATITUDE SPECIFICATION IN THE LEGEND
C*    OF MOST LAMBERT CONFORMAL MAPS.  IF THE MAP SPECIFIES "SCALE 
C*    1:XXXXX TRUE AT 40N AND 60N", THEN EQVLAT(40.,60.) WILL RETURN THE
C*    EQUIVALENT TANGENT LATITUDE.
C*  INPUTS:
C*    XLAT1,XLAT2:  THE TWO LATITUDES SPECIFIED IN THE MAP LEGEND
C*  RETURNS:
C*    THE EQUIVALENT TANGENT LATITUDE
C*  EXAMPLE:  CALL STLMBR(STRCMP, EQVLAT(40.,60.), 90.)

C*  SUBROUTINE STCM2P (STRCMP, X1,Y1, XLAT1,XLONG1,
C*          X2,Y2, XLAT2,XLONG2)
C*  SUBROUTINE STCM1P (STRCMP, X1,Y1, XLAT1,XLONG1,
C*          XLATG,XLONGG, GRIDSZ, ORIENT)
C*    THESE ROUTINES COMPLETE THE SPECIFICATION OF THE MAP STRUCTURE
C*    ARRAY BY CONFORMING THE MAP COORDINATES TO THE SPECIFICATIONS
C*    OF A PARTICULAR GRID.  EITHER STCM1P OR STCM2P MUST BE CALLED,
C*    BUT NOT BOTH
C*  INPUTS:
C*    STRCMP - A 9-VALUE MAP STRUCTURE ARRAY, SET TO A PARTICULAR MAP
C*             FORM BY A PREVIOUS CALL TO STLMBR
C*    FOR STCM2P:
C*      X1,Y1, X2,Y2 - THE MAP COORDINATES OF TWO POINTS ON THE GRID
C*      XLAT1,XLONG1, XLAT2,XLONG2 - THE GEOGRAPHIC COORDINATES OF THE
C*             SAME TWO POINTS
C*    FOR STCM1P:
C*      X1,Y1 - THE MAP COORDINATES OF ONE POINT ON THE GRID
C*      XLAT1,XLONG1 - THE GEOGRAPHIC COORDINATES OF THE SAME POINT
C*      XLATG,XLONGG - LATITUDE AND LONGITUDE OF REFERENCE POINT FOR
C*             GRIDSZ AND ORIENTATION SPECIFICATION.
C*      GRIDSZ - THE DESIRED GRID SIZE IN KILOMETERS, AT XLATG,XLONGG
C*      ORIENT - THE ANGLE, WITH RESPECT TO NORTH, OF A Y-GRID LINE, AT
C*             THE POINT XLATG,XLONGG
C*  OUTPUTS:
C*    STRCMP - A 9-VALUE MAP STRUCTURE ARRAY, FULLY SET FOR USE BY
C*             OTHER SUBROUTINES IN THIS SYSTEM

C*  SUBROUTINE CLL2XY (STRCMP, XLAT,XLONG, X,Y)
C*  SUBROUTINE CXY2LL (STRCMP, X,Y, XLAT,XLONG)
C*     THESE ROUTINES CONVERT BETWEEN MAP COORDINATES X,Y
C*     AND GEOGRAPHIC COORDINATES XLAT,XLONG
C*  INPUTS:
C*     STRCMP(9) - 9-VALUE MAP STRUCTURE ARRAY
C*     FOR CLL2XY:  XLAT,XLONG - GEOGRAPHIC COORDINATES
C*     FOR CXY2LL:  X,Y - MAP COORDINATES
C*  OUTPUTS:
C*     FOR CLL2XY:  X,Y - MAP COORDINATES
C*     FOR CXY2LL:  XLAT,XLONG - GEOGRAPHIC COORDINATES

C*  SUBROUTINE CC2GXY (STRCMP, X,Y, UE,VN, UG,VG)
C*  SUBROUTINE CG2CXY (STRCMP, X,Y, UG,VG, UE,VN)
C*  SUBROUTINE CC2GLL (STRCMP, XLAT,XLONG, UE,VN, UG,VG)
C*  SUBROUTINE CG2CLL (STRCMP, XLAT,XLONG, UG,VG, UE,VN)
C*     THESE SUBROUTINES CONVERT VECTOR WIND COMPONENTS FROM
C*     GEOGRAPHIC, OR COMPASS, COORDINATES, TO MAP OR
C*     GRID COORDINATES.  THE SITE OF THE WIND TO BE
C*     CONVERTED MAY BE GIVEN EITHER IN GEOGRAPHIC OR
C*     MAP COORDINATES.  WIND COMPONENTS ARE ALL IN KILOMETERS
C*     PER HOUR, WHETHER GEOGRAPHIC OR MAP COORDINATES.
C*  INPUTS:
C*    STRCMP(9) - 9-VALUE MAP STRUCTURE ARRAY
C*    FOR CC2GXY AND CG2CXY:  X,Y        -  MAP COORDINATES OF SITE
C*    FOR CC2GLL AND CG2CLL:  XLAT,XLONG -  GEOGRAPHIC COORDINATES OF SITE
C*    FOR CC2GXY AND CC2GLL:  UE,VN - EAST AND NORTH WIND COMPONENTS
C*    FOR CG2CXY AND CG2CLL:  UG,VG - X- AND Y- DIRECTION WIND COMPONENTS
C*  OUTPUTS:
C*    FOR CC2GXY AND CC2GLL:  UG,VG - X- AND Y- DIRECTION WIND COMPONENTS
C*    FOR CG2CXY AND CG2CLL:  UE,VN - EAST AND NORTH WIND COMPONENTS

C*  SUBROUTINE CCRVXY (STRCMP, X, Y,       GX,GY)
C*  SUBROUTINE CCRVLL (STRCMP, XLAT,XLONG, GX,GY)
C*    THESE SUBROUTINES RETURN THE CURVATURE VECTOR (GX,GY), AS REFERENCED
C*    TO MAP COORDINATES, INDUCED BY THE MAP TRANSFORMATION.  WHEN
C*    NON-LINEAR TERMS IN WIND SPEED ARE IMPORTANT, A "GEODESIC" FORCE
C*    SHOULD BE INCLUDED IN THE VECTOR FORM [ (U,U) G - (U,G) U ] WHERE THE
C*    INNER PRODUCT (U,G) IS DEFINED AS UX*GX + UY*GY.
C*  INPUTS:
C*    STRCMP(9) - 9-VALUE MAP STRUCTURE ARRAY
C*    FOR CCRVXY:  X,Y        -  MAP COORDINATES OF SITE
C*    FOR CCRVLL:  XLAT,XLONG -  GEOGRAPHIC COORDINATES OF SITE
C*  OUTPUTS:
C*    GX,GY       - VECTOR COEFFICIENTS OF CURVATURE, IN UNITS RADIANS
C*                  PER KILOMETER

C*  REAL FUNCTION CGSZLL (STRCMP, XLAT,XLONG)
C*  REAL FUNCTION CGSZXY (STRCMP, X,Y)
C*    THESE FUNCTIONS RETURN THE SIZE, IN KILOMETERS, OF EACH UNIT OF
C*    MOTION IN MAP COORDINATES (GRID SIZE).  THE GRID SIZE AT ANY
C*    LOCATION DEPENDS ON THAT LOCATION; THE POSITION MAY BE GIVEN IN
C*    EITHER MAP OR GEOGRAPHIC COORDINATES.
C*  INPUTS:
C*    STRCMP(9) - 9-VALUE MAP STRUCTURE ARRAY
C*    FOR CGSZXY:  X,Y        -  MAP COORDINATES OF SITE
C*    FOR CGSZLL:  XLAT,XLONG -  GEOGRAPHIC COORDINATES OF SITE
C*  RETURNS:
C*    GRIDSIZE IN KILOMETERS AT GIVEN SITE.

C*  SUBROUTINE CPOLXY (STRCMP, X,Y, ENX,ENY,ENZ)
C*  SUBROUTINE CPOLLL (STRCMP, XLAT,XLONG, ENX,ENY,ENZ)
C*    THESE SUBROUTINES PROVIDE 3-D VECTOR COMPONENTS OF A UNIT VECTOR
C*    IN THE DIRECTION OF THE NORTH POLAR AXIS.  WHEN MULTIPLIED
C*    BY TWICE THE ROTATION RATE OF THE EARTH (2 * PI/24 HR), THE
C*    VERTICAL COMPONENT YIELDS THE CORIOLIS FACTOR.
C*  INPUTS:
C*    STRCMP(9) - 9-VALUE MAP STRUCTURE ARRAY
C*    FOR CPOLXY:  X,Y        -  MAP COORDINATES OF SITE
C*    FOR CPOLLL:  XLAT,XLONG -  GEOGRAPHIC COORDINATES OF SITE
C*  RETURNS:
C*    ENX,ENY,ENZ THE DIRECTION COSINES OF A UNIT VECTOR IN THE
C*    DIRECTION OF THE ROTATION AXIS OF THE EARTH

C*  SUBROUTINE CNLLXY (STRCMP, XLAT,XLONG, XI,ETA)
C*  SUBROUTINE CNXYLL (STRCMP, XI,ETA, XLAT,XLONG)
C*    THESE SUBROUTINES PERFORM THE UNDERLYING TRANSFORMATIONS FROM
C*    GEOGRAPHIC COORDINATES TO AND FROM CANONICAL (EQUATOR CENTERED)
C*    COORDINATES.  THEY ARE CALLED BY CXY2LL AND CLL2XY, BUT ARE NOT
C*    INTENDED TO BE CALLED DIRECTLY

C*  REAL FUNCTION CSPANF (VALUE, BEGIN, END)
C*    THIS FUNCTION ASSISTS OTHER ROUTINES IN PROVIDING A LONGITUDE IN
C*    THE PROPER RANGE.  IT ADDS TO VALUE WHATEVER MULTIPLE OF 
C*    (END - BEGIN) IS NEEDED TO RETURN A NUMBER BEGIN < CSPANF <= END

	SUBROUTINE STLMBR(STRCMP, TNGLAT, XLONG)
C*  WRITTEN ON 3/31/94 BY Dr. Albion Taylor  NOAA / OAR / ARL
	PARAMETER (PI=3.14159265358979,RADPDG=PI/180,DGPRAD=180/PI)
	PARAMETER (REARTH=6 371.2)
	REAL STRCMP(9)
	STRCMP(1) = SIN(RADPDG * TNGLAT)
C*  GAMMA = SINE OF THE TANGENT LATITUDE
	STRCMP(2) = CSPANF( XLONG, -180., +180.)
C* LAMBDA_0 = REFERENCE LONGITUDE
	STRCMP(3) = 0.
C* X_0 = X- GRID COORDINATE OF ORIGIN (XI,ETA) = (0.,0.)
	STRCMP(4) = 0.
C* y_0 = Y-GRID COORDINATE OF ORIGIN (XI,ETA) = (0.,0.)
	STRCMP(5) = 1.
C* COSINE OF ROTATION ANGLE FROM XI,ETA TO X,Y
	STRCMP(6) = 0.
C* SINE OF ROTATION ANGLE FROM XI,ETA TO X,Y
	STRCMP(7) = REARTH
C* GRIDSIZE IN KILOMETERS AT THE EQUATOR
	CALL CNLLXY(STRCMP, 89.,XLONG, XI,ETA)
	STRCMP(8) = 2. * ETA - STRCMP(1) * ETA * ETA
C* RADIAL COORDINATE FOR 1 DEGREE FROM NORTH POLE
	CALL CNLLXY(STRCMP, -89.,XLONG, XI,ETA)
   	STRCMP(9) = 2. * ETA - STRCMP(1) * ETA * ETA
C* RADIAL COORDINATE FOR 1 DEGREE FROM SOUTH POLE
	RETURN
	END