PROGRAM TEST 00110 CHARACTER*10 LEVEL*6,DTE,TME 00120 INTEGER UNIT 00130 DATA LEVEL/'.01J. '/ 00140 CALL DATE(DTE) 00150 CALL TIME(TME) 00160 PRINT 1,LEVEL,DTE,TME 00170 1 FORMAT('1BXPORT',3A) 00180 WRITE(UNIT,1) LEVEL,DTE,TME 00190 RETURN 00200 END 00210 C ****************************************************************** 00220 C -----BXPORT, SOURCE CODE FOR BOXLIB 00230 C A LIBRARY OF TOOLS FOR USING BOXES AND OTHER GLOBAL 00240 C GRID SYSTEMS, E.G. MARSDEN SQUARES. THE BOX SYSTEMS ARE: 00250 C GENERIC NAME SPECIFIC NAME POLAR BOXES X-ORIGIN 00260 C ============ ============= =========== ======== 00270 C BOX2 BX16202 YES 0E 00280 C BOX4 BX4052 YES 0E 00290 C BOX10 BX648 NO 30E 00300 C 00310 C ===1=========2=========3=========4=========5=========6=========7== 00320 C 00330 C -----------REVISION HISTORY--------------------------------------- 00340 C LEVEL AUTHOR DATE DESCRIPTION 00350 C ===== ====== ========== ==================== 00360 C .01A. --- 83/07/20. ORIGINAL VERSION TAKEN QLIBS.01I VIA F45 00370 C .01B. SDW 83/07/21. UPDATES BOX10 TOOLS TO CURRENT SYSTEM 00380 C .01C. SDW 84/05/02. FIX ERROR IN , COMMENT OUT , 00390 C AND ADD . 00400 C .01D. TSP 84/10/05. FIXED TO ADJUST FOR 30 DEGREE 00410 C SHIFT OF B10 SYSTEM 00420 C .01E. TSP 84/10/08. FIXED ERRORS IN 00430 C .01F. TSP 84/10/08. FIXED AND 00440 C .01G. TSP 84/10/09. DELETED AND , TRIMMED ALL 00450 C LINES TO 72 CHARACTERS MAXIMUM 00460 C .01H. TSP 84/10/09. DELETED , , AND 00470 C .01I. TSP 84/10/10. CHANGED NAMES OF SOURCE AND 00480 C OBJECT CODE. 00490 C .01J. TSP 84/10/15. DELETED BOX5 AND AUTHOR COMMENT LINES. 00500 C ------------------------------------------------------------------ 00510 C ===1=========2=========3=========4=========5=========6=========7== 00520 INTEGER FUNCTION B10MSQ(MSQ) 00530 C -----------EQUALS -1 IF ILLEGAL MSQ ELSE EQUALS EQUIVALENT B10 00540 IMPLICIT INTEGER(A-Z) 00550 IF(MSQ.GE.1.AND.MSQ.LE.288)THEN 00560 SQR=MSQ+35 00570 ELSE IF(MSQ.GE.300.AND.MSQ.LE.623)THEN 00580 SQR=-1*(MSQ-300) 00590 ELSE IF(MSQ.GE.901.AND.MSQ.LE.936)THEN 00600 SQR=MSQ-577 00610 ELSE 00620 GOTO 900 00630 ENDIF 00640 B10MSQ=(9-SQR/36)*36 +(71-MOD(IABS(SQR),36)) 00650 + -(71-MOD(IABS(SQR),36))/39*36 -2 00660 RETURN 00670 900 B10MSQ=-1 00680 RETURN 00690 END 00700 C ===1=========2=========3=========4=========5=========6=========7== 00710 LOGICAL FUNCTION B1026(B2,B26,B10) 00720 C -----------FALSE IF 1>@B10>648, ELSE TRUE SUCH THAT @B2 CONTAINS 00730 C THE 25 BOX2 CONTAINED BY BOX10 @B10 IN NUMERICAL ORDER, 00740 C AND @B26 CONTAINS ZERO OR THE 26TH BOX2 FOR THE POLAR 00750 C BOX10. 00760 IMPLICIT INTEGER(A-Z) 00770 LOGICAL XYB10,B2XY0 00780 DIMENSION B2(25) 00790 JB=B26=0 00800 B1026=.FALSE. 00810 IF(.NOT.XYB10(X1,Y2,B10)) RETURN 00820 X2=X1+80 00830 Y1=Y2+80 00840 DO 500 Y=Y1,Y2,-20 00850 DO 500 X=X1,X2, 20 00860 IF(.NOT.B2XY0(X,Y,BOX2)) RETURN 00870 JB=JB+1 00880 B2(JB)=BOX2 00890 500 CONTINUE 00900 IF(B10.EQ. 1) B26= 1 00910 IF(B10.EQ.648) B26=16202 00920 B1026=.TRUE. 00930 RETURN 00940 END 00950 C ===1=========2=========3=========4=========5=========6=========7== 00960 LOGICAL FUNCTION B10XY0(X,Y,B10) 00970 C -----------PERFORM ON 10 DEGREE BOX CORNER @X,@Y 00980 IMPLICIT INTEGER(A-E,G-Z) 00990 LOGICAL BQXY0 01000 DATA Q/100/,XDIM/36/,Y1/800/,YMOVE/8/,X2/3500/ 01010 C -- SHIFT LATITUDE X 30 DEGREES WEST TO COMPUTE USING BQXY0 01020 IF (X .GE. 300) THEN 01030 XS=X-300 01040 ELSE 01050 XS=X+3300 01060 ENDIF 01070 B10XY0=BQXY0(XS,Y,B10,Q,XDIM,Y1,YMOVE,X2) 01080 C -- SUBTRACT 1 FROM BOX # TO ADJUST FOR LACK OF NORTH POLAR BOX 01090 B10=B10-1 01100 RETURN 01110 END 01120 C ===1=========2=========3=========4=========5=========6=========7== 01130 C *F45V1P0* 01140 LOGICAL FUNCTION B2XY0(X,Y,B2) 01150 C -----------PERFORM ON 2 DEGREE BOX CORNER @X,@Y 01160 IMPLICIT INTEGER(A-E,G-Z) 01170 LOGICAL BQXY0 01180 DATA Q/20/,XDIM/180/,Y1/880/,YMOVE/44/,X2/3580/ 01190 B2XY0=BQXY0(X,Y,B2,Q,XDIM,Y1,YMOVE,X2) 01200 RETURN 01210 END 01220 C ===1=========2=========3=========4=========5=========6=========7== 01230 C *F45V1P0* 01240 LOGICAL FUNCTION B4XY0(X,Y,B4) 01250 C ---- FALSE IF @X,@Y ARE NOT THE LOWER-LEFT (SW) CORNER OF A 01260 C @Q/10 DEGREE BOX IN 10THS DEGREE +N,-S,E. 01270 C ELSE TRUE RETURNING THE BOX NUMBER @B4 01280 C WHERE @XDIM IS THE NUMBER OF BOXES PER LAT ZONE 01290 C @Y1 IS 900-@Q 01300 C @X2 IS THE LARGEST X 01310 C 01320 C WARNING - DO NOT USE THIS FUNCTION FOR THE POLAR BOXES. 01330 C CANNOT RECOGNIZE (0,900) AS THE SOUTHWEST 01340 C CORNER OF THE NORTH POLAR BOX, AND ALL BOXES IN THE 01350 C -85 TO -90 DEGREE LATITUDE BAND HAVE (@X,@Y)=(0,-900) 01360 C AS THEIR SOUTHWEST CORNER. THUS CANNOT TELL 01370 C WHICH BOX IS THE SOUTH POLAR BOX WHEN GIVEN (0,-900). 01380 C 01390 C RETURNS .FALSE. FOR NORTH POLAR BOX. 01400 C RETURNS .TRUE. FOR SOUTH POLAR BOX; BUT 01410 C THE RETURNED BOX IS NOT THE SOUTH POLAR 01420 C BOX. 01430 C 01440 IMPLICIT INTEGER(A-E,G-Z) 01450 DATA Q/40/,XDIM/90/,Y1/860/,X2/3560/ 01460 IF(MOD(X,Q).EQ.0.AND.MOD(900-Y,Q).EQ.0.AND. 01470 + (X.GE.0.AND.X.LE.X2) .AND. 01480 + (Y.GE.-900.AND.Y.LE.Y1)) GOTO 200 01490 B4XY0=.FALSE. 01500 RETURN 01510 200 B4=((900-Y)/Q-1)*XDIM+X/Q+2 01520 B4XY0=.TRUE. 01530 RETURN 01540 END 01550 C ===1=========2=========3=========4=========5=========6=========7== 01560 C *F45V1P0* 01570 LOGICAL FUNCTION BQXY0(X,Y,BQ,Q,XDIM,Y1,YMOVE,X2) 01580 C ------FALSE IF @X,@Y ARE NOT THE LOWER-LEFT (SW) CORNER OF A @Q/10 01590 C DEGREE BOX IN 10THS DEGREE +N,-S,E; EXCLUDING POLAR BOXES 01600 C ELSE TRUE RETURNING THE BOX NUMBER @BQ 01610 C WHERE @XDIM IS THE NUMBER OF BOXES PER LAT ZONE 01620 C @Y1 IS 900-@Q 01630 C @YMOVE IS (900/@Q)-1 01640 C @X2 IS THE LARGEST X 01650 C 01660 C WARNING - DO NOT USE THIS FUNCTION FOR THE POLAR BOXES. 01670 C CANNOT RECOGNIZE (0,900) AS THE SOUTHWEST 01680 C CORNER OF THE NORTH POLAR BOX, AND ALL BOXES IN THE 01690 C -85 TO -90 DEGREE LATITUDE BAND HAVE (@X,@Y)=(0,-900) 01700 C AS THEIR SOUTHWEST CORNER. THUS CANNOT TELL 01710 C WHICH BOX IS THE SOUTH POLAR BOX WHEN GIVEN (0,-900). 01720 C 01730 C RETURNS .FALSE. FOR NORTH POLAR BOX. 01740 C RETURNS .TRUE. FOR SOUTH POLAR BOX; BUT 01750 C THE RETURNED BOX IS NOT THE SOUTH POLAR 01760 C BOX. 01770 C 01780 IMPLICIT INTEGER(A-E,G-Z) 01790 IF(MOD(X,Q).EQ.0.AND.MOD(Y,Q).EQ.0.AND. 01800 + (X.GE.0.AND.X.LE.X2) .AND. 01810 + (Y.GE.-900.AND.Y.LE.Y1)) GOTO 200 01820 BQXY0=.FALSE. 01830 RETURN 01840 200 BQ=(YMOVE-Y/Q)*XDIM+X/Q+2 01850 BQXY0=.TRUE. 01860 RETURN 01870 C ** THIS PROGRAM VALID ON FTN4 AND FTN5 ** 01880 END 01890 C ===1=========2=========3=========4=========5=========6=========7== 01900 INTEGER FUNCTION MSQB10(B10) 01910 C -----------EQUALS -1 IF ILLEGAL B10, ELSE EQUALS EQUIVALENT MSQ 01920 IMPLICIT INTEGER(A-E,G-Z) 01930 MSQB10=-1 01940 M=MOD(B10,36) 01950 IF (M .EQ. 0) M=36 01960 IF (B10 .GE. 1 .AND. B10 .LE. 33) THEN 01970 MSQB10 = 934-B10 01980 ELSE 01990 MSQB10 = 970-B10 02000 ENDIF 02010 IF (B10 .GE. 37 .AND. B10 .LE. 324) THEN 02020 IF (M .GE. 1 .AND. M .LE. 33) THEN 02030 MSQB10 = 322-B10 02040 ELSE 02050 MSQB10 = 358-B10 02060 ENDIF 02070 ENDIF 02080 IF (B10 .GE. 325 .AND. B10 .LE. 648) THEN 02090 IF (M .GE. 1 .AND. M .LE. 33) THEN 02100 MSQB10 = 333-M+((AINT(B10/36.0)-9)*36) 02110 ELSE IF (M .EQ. 34 .OR. M .EQ. 35) THEN 02120 MSQB10 = 369-M+((AINT(B10/36.0)-9)*36) 02130 ELSE IF (M .EQ. 36) THEN 02140 MSQB10 = 333+((AINT(B10/36.0)-10)*36) 02150 ENDIF 02160 ENDIF 02170 RETURN 02180 END 02190 C ===1=========2=========3=========4=========5=========6=========7== 02200 C *F45V1P0* 02210 LOGICAL FUNCTION MSQXY0(X,Y,MSQ) 02220 C -----------RETURNS MSQ BOX# @MSQ GIVEN 10 DEGREE BOX CORNER @X, @Y 02230 C RETURNS FALSE IF @X,@Y IS NOT THE CORNER OF A 10 DEGREE 02240 C BOX. 02250 C 02260 C USES - SEE WARNING BELOW. 02270 C 02280 C WARNING - DO NOT USE THIS FUNCTION FOR THE POLAR BOXES. 02290 C CANNOT RECOGNIZE (0,900) AS THE SOUTHWEST 02300 C CORNER OF THE NORTH POLAR BOX, AND ALL BOXES IN THE 02310 C -85 TO -90 DEGREE LATITUDE BAND HAVE (@X,@Y)=(0,-900) 02320 C AS THEIR SOUTHWEST CORNER. THUS CANNOT TELL 02330 C WHICH BOX IS THE SOUTH POLAR BOX WHEN GIVEN (0,-900). 02340 C 02350 C RETURNS .FALSE. FOR NORTH POLAR BOX. 02360 C RETURNS .TRUE. FOR SOUTH POLAR BOX; BUT 02370 C THE RETURNED BOX IS NOT THE SOUTH POLAR 02380 C BOX. 02390 C 02400 IMPLICIT INTEGER(A-E,G-Z) 02410 LOGICAL BQXY0 02420 C -- SHIFT LATITUDE X 30 DEGREES WEST TO COMPUTE USING BQXY0 02430 IF (X .GE. 300) THEN 02440 XS=X-300 02450 ELSE 02460 XS=X+3300 02470 ENDIF 02480 DATA Q/100/,XDIM/36/,Y1/800/,YMOVE/8/,X2/3500/ 02490 MSQXY0=BQXY0(XS,Y,BQ,Q,XDIM,Y1,YMOVE,X2) 02500 C -- SUBTRACT 1 FROM BOX # TO ADJUST FOR LACK OF POLAR BOX AND 02510 C RECALCULATE THE EQUIVALENT MARSDEN SQUARE 02520 MSQ=MSQB10(BQ-1) 02530 RETURN 02540 END 02550 C ===1=========2=========3=========4=========5=========6=========7== 02560 INTEGER FUNCTION QCDCXY(X,Y) 02570 C ------RETURNS -1 UNLESS 900<@Y<-900, 3599<@X<0, @X<>1800 (10THS E) 02580 C RETURNS THE NCDC QUADRANT 1=NW,2=NE,3=SW,4=SE OTHERWISE 02590 IMPLICIT INTEGER(A-E,G-Z) 02600 IF(Y.LT.900.AND.Y.GT.-900.AND.X.LT.3599.AND.X.GT.0.AND.X.NE.1800) 02610 + THEN 02620 QCDCXY=1 02630 IF(X.LT.1800) QCDCXY=QCDCXY+1 02640 IF(Y.LT.0) QCDCXY=QCDCXY+2 02650 ELSE 02660 QCDCXY=-1 02670 ENDIF 02680 RETURN 02690 END 02700 C ===1=========2=========3=========4=========5=========6=========7== 02710 LOGICAL FUNCTION XYB10(X,Y,B10) 02720 C -----------PERFORM ON A 10 DEGREE BOX @B10 02730 IMPLICIT INTEGER(A-E,G-Z) 02740 LOGICAL XYBQ 02750 DATA Q/100/,LAST/648/,XDIM/36/,Y1/800/,POLE/1/,XMOVE/300/ 02760 XYB10=XYBQ(X,Y,B10,Q,LAST,XDIM,Y1,POLE,XMOVE) 02770 RETURN 02780 END 02790 C ===1=========2=========3=========4=========5=========6=========7== 02800 C *F45V1P0* 02810 LOGICAL FUNCTION XYB2(X,Y,B2) 02820 C -----------PERFORM ON A 2 DEGREE BOX @B2 02830 IMPLICIT INTEGER(A-E,G-Z) 02840 LOGICAL XYBQ 02850 DATA Q/20/,LAST/16202/,XDIM/180/,Y1/880/,POLE/2/,XMOVE/0/ 02860 XYB2=XYBQ(X,Y,B2,Q,LAST,XDIM,Y1,POLE,XMOVE) 02870 RETURN 02880 END 02890 C ===1=========2=========3=========4=========5=========6=========7== 02900 C *F45V1P0* 02910 LOGICAL FUNCTION XYB4(X,Y,B4) 02920 C -----------PERFORM ON A 4 DEGREE BOX @B4 02930 IMPLICIT INTEGER(A-E,G-Z) 02940 LOGICAL XYBQ 02950 DATA Q/40/,LAST/4052/,XDIM/90/,Y1/860/,POLE/2/,XMOVE/0/ 02960 XYB4=XYBQ(X,Y,B4,Q,LAST,XDIM,Y1,POLE,XMOVE) 02970 RETURN 02980 END 02990 C ===1=========2=========3=========4=========5=========6=========7== 03000 C *F45V1P0* 03010 LOGICAL FUNCTION XYBQ(X,Y,BQ,Q,LAST,XDIM,Y1,POLE,XMOVE) 03020 C ------FALSE IF 1>BQ>@LAST, ELSE TRUE SUCH THAT @X,@Y ARE THE 03030 C LAT,LON IN 10THS DEGREE +N,-S,E OF LOWER-LEFT (SW) CORNER 03040 C OF @Q/10 DEGREE BOX @BQ; POLAR @X ARE SET TO 0 03050 C WHERE @LAST IS THE LAST BOX NUMBER 03060 C @XDIM IS THE NUMBER OF BOXES PER LAT ZONE 03070 C @Y1 IS 900-@Q 03080 C @POLE IS 1 IF 0 POLAR BOXES, 2 IF 2 POLAR BOXES 03090 C @XMOVE IS THE X-ORIGIN 03100 IMPLICIT INTEGER(A-E,G-Z) 03110 XYBQ=.FALSE. 03120 IF(BQ.LT.1.OR.BQ.GT.LAST) RETURN 03130 IF(POLE.EQ.1) GOTO 200 03140 IF(BQ.NE.1) GOTO 100 03150 X=0 03160 Y= 900 03170 GOTO 900 03180 100 IF(BQ.NE.LAST) GOTO 200 03190 X=0 03200 Y=-900 03210 GOTO 900 03220 200 CONTINUE 03230 X=MOD(BQ-POLE,XDIM)*Q+XMOVE 03240 IF(X.GE.3600) X=X-3600 03250 Y=Y1-(BQ-POLE)/XDIM*Q 03260 900 XYBQ=.TRUE. 03270 RETURN 03280 C ** THIS PROGRAM VALID ON FTN4 AND FTN5 ** 03290 END 03300 C ===1=========2=========3=========4=========5=========6=========7== 03310 LOGICAL FUNCTION XYMSQ(X,Y,MSQ) 03320 C ---------- PERFORM TO CONVERT @MSQ TO @B10, THEN USES 03330 C TO FIND LAT. AND LONG. OF EQUIVALENT @B10 03340 IMPLICIT INTEGER(A-E,G-Z) 03350 LOGICAL XYBQ 03360 B10 = B10MSQ(MSQ) 03370 DATA Q/100/,LAST/648/,XDIM/36/,Y1/800/,POLE/1/,XMOVE/300/ 03380 XYMSQ=XYBQ(X,Y,B10,Q,LAST,XDIM,Y1,POLE,XMOVE) 03390 RETURN 03400 END 03410