Back to home page

MITgcm
 
 

    

File indexing completed on 2023-05-28 05:10:57 UTC

view on githubraw file Latest commit b4daa243 on 2023-05-28 03:53:22 UTC
b4daa24319 Shre*0001 C ************************ integer*4 ************************
                0002       BLOCK DATA INTEGERS4
                0003       INTEGER*4 adi4buf(512)
                0004       INTEGER adi4ibuf
                0005       COMMON /adi4fbuf/adi4buf,adi4ibuf
                0006       DATA adi4ibuf/1/
                0007       END
                0008 
                0009       SUBROUTINE PUSHINTEGER4(x)
                0010       INTEGER*4 x, adi4buf(512)
                0011       INTEGER adi4ibuf
                0012       COMMON /adi4fbuf/adi4buf,adi4ibuf
                0013       CALL addftraffic(4)
                0014       adi4buf(adi4ibuf) = x
                0015       IF (adi4ibuf.eq.512) THEN
                0016          CALL PUSHINTEGER4ARRAY(adi4buf, 512)
                0017          CALL addftraffic(-512*4)
                0018          adi4ibuf = 1
                0019       ELSE
                0020          adi4ibuf = adi4ibuf+1
                0021       ENDIF
                0022       END
                0023 
                0024       SUBROUTINE POPINTEGER4(x)
                0025       INTEGER*4 x, adi4buf(512)
                0026       INTEGER adi4ibuf
                0027       COMMON /adi4fbuf/adi4buf,adi4ibuf
                0028       IF (adi4ibuf.le.1) THEN
                0029          CALL POPINTEGER4ARRAY(adi4buf, 512)
                0030          adi4ibuf = 512
                0031       ELSE
                0032          adi4ibuf = adi4ibuf-1         
                0033       ENDIF
                0034       x = adi4buf(adi4ibuf)
                0035       END
                0036 
                0037 C ************************ integer*8 ************************
                0038       BLOCK DATA INTEGERS8
                0039       INTEGER*8 adi8buf(512)
                0040       INTEGER adi8ibuf
                0041       COMMON /adi8fbuf/adi8buf,adi8ibuf
                0042       DATA adi8ibuf/1/
                0043       END
                0044 
                0045       SUBROUTINE PUSHINTEGER8(x)
                0046       INTEGER*8 x, adi8buf(512)
                0047       INTEGER adi8ibuf
                0048       COMMON /adi8fbuf/adi8buf,adi8ibuf
                0049       CALL addftraffic(8)
                0050       adi8buf(adi8ibuf) = x
                0051       IF (adi8ibuf.eq.512) THEN
                0052          CALL PUSHINTEGER8ARRAY(adi8buf, 512)
                0053          CALL addftraffic(-8*512)
                0054          adi8ibuf = 1
                0055       ELSE
                0056          adi8ibuf = adi8ibuf+1
                0057       ENDIF
                0058       END
                0059 
                0060       SUBROUTINE POPINTEGER8(x)
                0061       INTEGER*8 x, adi8buf(512)
                0062       INTEGER adi8ibuf
                0063       COMMON /adi8fbuf/adi8buf,adi8ibuf
                0064       IF (adi8ibuf.le.1) THEN
                0065          CALL POPINTEGER8ARRAY(adi8buf, 512)
                0066          adi8ibuf = 512
                0067       ELSE
                0068          adi8ibuf = adi8ibuf-1         
                0069       ENDIF
                0070       x = adi8buf(adi8ibuf)
                0071       END
                0072 
                0073 C ************************ real*4 ************************
                0074       BLOCK DATA REALS4
                0075       REAL*4 adr4buf(512)
                0076       INTEGER adr4ibuf
                0077       COMMON /adr4fbuf/adr4buf,adr4ibuf
                0078       DATA adr4ibuf/1/
                0079       END
                0080 
                0081       SUBROUTINE PUSHREAL4(x)
                0082       REAL*4 x, adr4buf(512)
                0083       INTEGER adr4ibuf
                0084       COMMON /adr4fbuf/adr4buf,adr4ibuf
                0085       CALL addftraffic(4)
                0086       adr4buf(adr4ibuf) = x
                0087       IF (adr4ibuf.eq.512) THEN
                0088          CALL PUSHREAL4ARRAY(adr4buf, 512)
                0089          CALL addftraffic(-4*512)
                0090          adr4ibuf = 1
                0091       ELSE
                0092          adr4ibuf = adr4ibuf+1
                0093       ENDIF
                0094       END
                0095 
                0096       SUBROUTINE POPREAL4(x)
                0097       REAL*4 x, adr4buf(512)
                0098       INTEGER adr4ibuf
                0099       COMMON /adr4fbuf/adr4buf,adr4ibuf
                0100       IF (adr4ibuf.le.1) THEN
                0101          CALL POPREAL4ARRAY(adr4buf, 512)
                0102          adr4ibuf = 512
                0103       ELSE
                0104          adr4ibuf = adr4ibuf-1         
                0105       ENDIF
                0106       x = adr4buf(adr4ibuf)
                0107       END
                0108 
                0109 C ************************ real*8 ************************
                0110       BLOCK DATA REALS8
                0111       REAL*8 adr8buf(512)
                0112       INTEGER adr8ibuf
                0113       COMMON /adr8fbuf/adr8buf,adr8ibuf
                0114       DATA adr8ibuf/1/
                0115       END
                0116 
                0117       SUBROUTINE PUSHREAL8(x)
                0118       REAL*8 x, adr8buf(512)
                0119       INTEGER adr8ibuf
                0120       COMMON /adr8fbuf/adr8buf,adr8ibuf
                0121       CALL addftraffic(8)
                0122       adr8buf(adr8ibuf) = x
                0123       IF (adr8ibuf.eq.512) THEN
                0124          CALL PUSHREAL8ARRAY(adr8buf, 512)
                0125          CALL addftraffic(-8*512)
                0126          adr8ibuf = 1
                0127       ELSE
                0128          adr8ibuf = adr8ibuf+1
                0129       ENDIF
                0130       END
                0131 
                0132       SUBROUTINE POPREAL8(x)
                0133       REAL*8 x, adr8buf(512)
                0134       INTEGER adr8ibuf
                0135       COMMON /adr8fbuf/adr8buf,adr8ibuf
                0136       IF (adr8ibuf.le.1) THEN
                0137          CALL POPREAL8ARRAY(adr8buf, 512)
                0138          adr8ibuf = 512
                0139       ELSE
                0140          adr8ibuf = adr8ibuf-1         
                0141       ENDIF
                0142       x = adr8buf(adr8ibuf)
                0143       END
                0144 
                0145 C ************************ complex*8 ************************
                0146       BLOCK DATA COMPLEXS8
                0147       COMPLEX*8 adc8buf(512)
                0148       INTEGER adc8ibuf
                0149       COMMON /adc8fbuf/adc8buf,adc8ibuf
                0150       DATA adc8ibuf/1/
                0151       END
                0152 
                0153       SUBROUTINE PUSHCOMPLEX8(x)
                0154       COMPLEX*8 x, adc8buf(512)
                0155       INTEGER adc8ibuf
                0156       COMMON /adc8fbuf/adc8buf,adc8ibuf
                0157       CALL addftraffic(8)
                0158       adc8buf(adc8ibuf) = x
                0159       IF (adc8ibuf.eq.512) THEN
                0160          CALL PUSHCOMPLEX8ARRAY(adc8buf, 512)
                0161          CALL addftraffic(-8*512)
                0162          adc8ibuf = 1
                0163       ELSE
                0164          adc8ibuf = adc8ibuf+1
                0165       ENDIF
                0166       END
                0167 
                0168       SUBROUTINE POPCOMPLEX8(x)
                0169       COMPLEX*8 x, adc8buf(512)
                0170       INTEGER adc8ibuf
                0171       COMMON /adc8fbuf/adc8buf,adc8ibuf
                0172       IF (adc8ibuf.le.1) THEN
                0173          CALL POPCOMPLEX8ARRAY(adc8buf, 512)
                0174          adc8ibuf = 512
                0175       ELSE
                0176          adc8ibuf = adc8ibuf-1         
                0177       ENDIF
                0178       x = adc8buf(adc8ibuf)
                0179       END
                0180 
                0181 C ************************ complex*16 ************************
                0182       BLOCK DATA COMPLEXS16
                0183       COMPLEX*16 adc16buf(512)
                0184       INTEGER adc16ibuf
                0185       COMMON /adc16fbuf/adc16buf,adc16ibuf
                0186       DATA adc16ibuf/1/
                0187       END
                0188 
                0189       SUBROUTINE PUSHCOMPLEX16(x)
                0190       COMPLEX*16 x, adc16buf(512)
                0191       INTEGER adc16ibuf
                0192       COMMON /adc16fbuf/adc16buf,adc16ibuf
                0193       CALL addftraffic(16)
                0194       adc16buf(adc16ibuf) = x
                0195       IF (adc16ibuf.eq.512) THEN
                0196          CALL PUSHCOMPLEX16ARRAY(adc16buf, 512)
                0197          CALL addftraffic(-16*512)
                0198          adc16ibuf = 1
                0199       ELSE
                0200          adc16ibuf = adc16ibuf+1
                0201       ENDIF
                0202       END
                0203 
                0204       SUBROUTINE POPCOMPLEX16(x)
                0205       COMPLEX*16 x, adc16buf(512)
                0206       INTEGER adc16ibuf
                0207       COMMON /adc16fbuf/adc16buf,adc16ibuf
                0208       IF (adc16ibuf.le.1) THEN
                0209          CALL POPCOMPLEX16ARRAY(adc16buf, 512)
                0210          adc16ibuf = 512
                0211       ELSE
                0212          adc16ibuf = adc16ibuf-1         
                0213       ENDIF
                0214       x = adc16buf(adc16ibuf)
                0215       END
                0216 
                0217 C ************************ character ************************
                0218       BLOCK DATA CHARACTERS
                0219       CHARACTER ads1buf(512)
                0220       INTEGER ads1ibuf
                0221       COMMON /ads1fbuf/ads1buf,ads1ibuf
                0222       DATA ads1ibuf/1/
                0223       END
                0224 
                0225       SUBROUTINE PUSHCHARACTER(x)
                0226       CHARACTER x, ads1buf(512)
                0227       INTEGER ads1ibuf
                0228       COMMON /ads1fbuf/ads1buf,ads1ibuf
                0229       CALL addftraffic(1)
                0230       ads1buf(ads1ibuf) = x
                0231       IF (ads1ibuf.eq.512) THEN
                0232          CALL PUSHNARRAY(ads1buf, 512, 1)
                0233          CALL addftraffic(-512)
                0234          ads1ibuf = 1
                0235       ELSE
                0236          ads1ibuf = ads1ibuf+1
                0237       ENDIF
                0238       END
                0239 
                0240       SUBROUTINE POPCHARACTER(x)
                0241       CHARACTER x, ads1buf(512)
                0242       INTEGER ads1ibuf
                0243       COMMON /ads1fbuf/ads1buf,ads1ibuf
                0244       IF (ads1ibuf.le.1) THEN
                0245          CALL POPNARRAY(ads1buf, 512, 1)
                0246          ads1ibuf = 512
                0247       ELSE
                0248          ads1ibuf = ads1ibuf-1         
                0249       ENDIF
                0250       x = ads1buf(ads1ibuf)
                0251       END
                0252 
                0253 C ******************* bit (hidden primitives) ***************
                0254       BLOCK DATA BITS
                0255       INTEGER*4 adbitbuf
                0256       INTEGER adbitibuf
                0257       COMMON /adbitfbuf/adbitbuf, adbitibuf
                0258       DATA adbitbuf/0/
                0259       DATA adbitibuf/0/
                0260       END
                0261 
                0262       SUBROUTINE PUSHBIT(bit)
                0263       LOGICAL bit
                0264       INTEGER*4 adbitbuf
                0265       INTEGER adbitibuf
                0266       COMMON /adbitfbuf/adbitbuf, adbitibuf
                0267       IF (bit) THEN
                0268          adbitbuf = IBSET(adbitbuf, adbitibuf)
                0269       ELSE
                0270          adbitbuf = IBCLR(adbitbuf, adbitibuf)
                0271       ENDIF
                0272       IF (adbitibuf.ge.31) THEN
                0273          CALL PUSHNARRAY(adbitbuf, 4, 1)
                0274          adbitbuf = 0
                0275          adbitibuf = 0
                0276       ELSE
                0277          adbitibuf = adbitibuf+1
                0278       ENDIF
                0279       END
                0280 
                0281       LOGICAL FUNCTION POPBIT()
                0282       INTEGER*4 adbitbuf
                0283       INTEGER adbitibuf
                0284       COMMON /adbitfbuf/adbitbuf, adbitibuf
                0285       IF (adbitibuf.le.0) THEN
                0286          CALL POPNARRAY(adbitbuf, 4, 1)
                0287          adbitibuf = 31
                0288       ELSE
                0289          adbitibuf = adbitibuf-1
                0290       ENDIF
                0291       POPBIT = BTEST(adbitbuf, adbitibuf)
                0292       END
                0293 
                0294 C *************************** boolean *************************
                0295       SUBROUTINE PUSHBOOLEAN(x)
                0296       LOGICAL x
                0297       CALL PUSHBIT(x)
                0298       END
                0299 
                0300       SUBROUTINE POPBOOLEAN(x)
                0301       LOGICAL x, POPBIT
                0302       x = POPBIT()
                0303       END
                0304 
                0305 C ************************* control ***********************
                0306 
                0307       SUBROUTINE PUSHCONTROL1B(cc)
                0308       INTEGER cc
                0309       CALL PUSHBIT(cc.ne.0)
                0310       END
                0311 
                0312       SUBROUTINE POPCONTROL1B(cc)
                0313       INTEGER cc
                0314       LOGICAL POPBIT
                0315       IF (POPBIT()) THEN
                0316          cc = 1
                0317       ELSE
                0318          cc = 0
                0319       ENDIF
                0320       END
                0321 
                0322       SUBROUTINE PUSHCONTROL2B(cc)
                0323       INTEGER cc
                0324       CALL PUSHBIT(BTEST(cc,0))
                0325       CALL PUSHBIT(BTEST(cc,1))
                0326       END
                0327 
                0328       SUBROUTINE POPCONTROL2B(cc)
                0329       INTEGER cc
                0330       LOGICAL POPBIT
                0331       IF (POPBIT()) THEN
                0332          cc = 2
                0333       ELSE
                0334          cc = 0
                0335       ENDIF
                0336       IF (POPBIT()) cc = IBSET(cc,0)
                0337       END
                0338 
                0339       SUBROUTINE PUSHCONTROL3B(cc)
                0340       INTEGER cc
                0341       CALL PUSHBIT(BTEST(cc,0))
                0342       CALL PUSHBIT(BTEST(cc,1))
                0343       CALL PUSHBIT(BTEST(cc,2))
                0344       END
                0345 
                0346       SUBROUTINE POPCONTROL3B(cc)
                0347       INTEGER cc
                0348       LOGICAL POPBIT
                0349       IF (POPBIT()) THEN
                0350          cc = 4
                0351       ELSE
                0352          cc = 0
                0353       ENDIF
                0354       IF (POPBIT()) cc = IBSET(cc,1)
                0355       IF (POPBIT()) cc = IBSET(cc,0)
                0356       END
                0357 
                0358       SUBROUTINE PUSHCONTROL4B(cc)
                0359       INTEGER cc
                0360       CALL PUSHBIT(BTEST(cc,0))
                0361       CALL PUSHBIT(BTEST(cc,1))
                0362       CALL PUSHBIT(BTEST(cc,2))
                0363       CALL PUSHBIT(BTEST(cc,3))
                0364       END
                0365 
                0366       SUBROUTINE POPCONTROL4B(cc)
                0367       INTEGER cc
                0368       LOGICAL POPBIT
                0369       IF (POPBIT()) THEN
                0370          cc = 8
                0371       ELSE
                0372          cc = 0
                0373       ENDIF
                0374       IF (POPBIT()) cc = IBSET(cc,2)
                0375       IF (POPBIT()) cc = IBSET(cc,1)
                0376       IF (POPBIT()) cc = IBSET(cc,0)
                0377       END
                0378 
                0379       SUBROUTINE PUSHCONTROL5B(cc)
                0380       INTEGER cc
                0381       CALL PUSHBIT(BTEST(cc,0))
                0382       CALL PUSHBIT(BTEST(cc,1))
                0383       CALL PUSHBIT(BTEST(cc,2))
                0384       CALL PUSHBIT(BTEST(cc,3))
                0385       CALL PUSHBIT(BTEST(cc,4))
                0386       END
                0387 
                0388       SUBROUTINE POPCONTROL5B(cc)
                0389       INTEGER cc
                0390       LOGICAL POPBIT
                0391       IF (POPBIT()) THEN
                0392          cc = 16
                0393       ELSE
                0394          cc = 0
                0395       ENDIF
                0396       IF (POPBIT()) cc = IBSET(cc,3)
                0397       IF (POPBIT()) cc = IBSET(cc,2)
                0398       IF (POPBIT()) cc = IBSET(cc,1)
                0399       IF (POPBIT()) cc = IBSET(cc,0)
                0400       END
                0401 
                0402       SUBROUTINE PUSHCONTROL6B(cc)
                0403       INTEGER cc
                0404       CALL PUSHBIT(BTEST(cc,0))
                0405       CALL PUSHBIT(BTEST(cc,1))
                0406       CALL PUSHBIT(BTEST(cc,2))
                0407       CALL PUSHBIT(BTEST(cc,3))
                0408       CALL PUSHBIT(BTEST(cc,4))
                0409       CALL PUSHBIT(BTEST(cc,5))
                0410       END
                0411 
                0412       SUBROUTINE POPCONTROL6B(cc)
                0413       INTEGER cc
                0414       LOGICAL POPBIT
                0415       IF (POPBIT()) THEN
                0416          cc = 32
                0417       ELSE
                0418          cc = 0
                0419       ENDIF
                0420       IF (POPBIT()) cc = IBSET(cc,4)
                0421       IF (POPBIT()) cc = IBSET(cc,3)
                0422       IF (POPBIT()) cc = IBSET(cc,2)
                0423       IF (POPBIT()) cc = IBSET(cc,1)
                0424       IF (POPBIT()) cc = IBSET(cc,0)
                0425       END
                0426 
                0427       SUBROUTINE PUSHCONTROL7B(cc)
                0428       INTEGER cc
                0429       CALL PUSHBIT(BTEST(cc,0))
                0430       CALL PUSHBIT(BTEST(cc,1))
                0431       CALL PUSHBIT(BTEST(cc,2))
                0432       CALL PUSHBIT(BTEST(cc,3))
                0433       CALL PUSHBIT(BTEST(cc,4))
                0434       CALL PUSHBIT(BTEST(cc,5))
                0435       CALL PUSHBIT(BTEST(cc,6))
                0436       END
                0437 
                0438       SUBROUTINE POPCONTROL7B(cc)
                0439       INTEGER cc
                0440       LOGICAL POPBIT
                0441       IF (POPBIT()) THEN
                0442          cc = 64
                0443       ELSE
                0444          cc = 0
                0445       ENDIF
                0446       IF (POPBIT()) cc = IBSET(cc,5)
                0447       IF (POPBIT()) cc = IBSET(cc,4)
                0448       IF (POPBIT()) cc = IBSET(cc,3)
                0449       IF (POPBIT()) cc = IBSET(cc,2)
                0450       IF (POPBIT()) cc = IBSET(cc,1)
                0451       IF (POPBIT()) cc = IBSET(cc,0)
                0452       END
                0453 
                0454       SUBROUTINE PUSHCONTROL8B(cc)
                0455       INTEGER cc
                0456       CALL PUSHBIT(BTEST(cc,0))
                0457       CALL PUSHBIT(BTEST(cc,1))
                0458       CALL PUSHBIT(BTEST(cc,2))
                0459       CALL PUSHBIT(BTEST(cc,3))
                0460       CALL PUSHBIT(BTEST(cc,4))
                0461       CALL PUSHBIT(BTEST(cc,5))
                0462       CALL PUSHBIT(BTEST(cc,6))
                0463       CALL PUSHBIT(BTEST(cc,7))
                0464       END
                0465 
                0466       SUBROUTINE POPCONTROL8B(cc)
                0467       INTEGER cc
                0468       LOGICAL POPBIT
                0469       IF (POPBIT()) THEN
                0470          cc = 128
                0471       ELSE
                0472          cc = 0
                0473       ENDIF
                0474       IF (POPBIT()) cc = IBSET(cc,6)
                0475       IF (POPBIT()) cc = IBSET(cc,5)
                0476       IF (POPBIT()) cc = IBSET(cc,4)
                0477       IF (POPBIT()) cc = IBSET(cc,3)
                0478       IF (POPBIT()) cc = IBSET(cc,2)
                0479       IF (POPBIT()) cc = IBSET(cc,1)
                0480       IF (POPBIT()) cc = IBSET(cc,0)
                0481       END
                0482 
                0483       SUBROUTINE PUSHCONTROL9B(cc)
                0484       INTEGER cc
                0485       CALL PUSHBIT(BTEST(cc,0))
                0486       CALL PUSHBIT(BTEST(cc,1))
                0487       CALL PUSHBIT(BTEST(cc,2))
                0488       CALL PUSHBIT(BTEST(cc,3))
                0489       CALL PUSHBIT(BTEST(cc,4))
                0490       CALL PUSHBIT(BTEST(cc,5))
                0491       CALL PUSHBIT(BTEST(cc,6))
                0492       CALL PUSHBIT(BTEST(cc,7))
                0493       CALL PUSHBIT(BTEST(cc,8))
                0494       END
                0495 
                0496       SUBROUTINE POPCONTROL9B(cc)
                0497       INTEGER cc
                0498       LOGICAL POPBIT
                0499       IF (POPBIT()) THEN
                0500          cc = 256
                0501       ELSE
                0502          cc = 0
                0503       ENDIF
                0504       IF (POPBIT()) cc = IBSET(cc,7)
                0505       IF (POPBIT()) cc = IBSET(cc,6)
                0506       IF (POPBIT()) cc = IBSET(cc,5)
                0507       IF (POPBIT()) cc = IBSET(cc,4)
                0508       IF (POPBIT()) cc = IBSET(cc,3)
                0509       IF (POPBIT()) cc = IBSET(cc,2)
                0510       IF (POPBIT()) cc = IBSET(cc,1)
                0511       IF (POPBIT()) cc = IBSET(cc,0)
                0512       END
                0513 
                0514 C ************************* pointer ************************
                0515 c Don't know how to write a PUSH/POPPOINTER() in Fortran
                0516 c Maybe one should always call the C version instead...
                0517 
                0518 C *********************************************************
                0519 C         HOW TO CREATE PUSH* POP* SUBROUTINES
                0520 C              YET FOR OTHER DATA TYPES
                0521 C  Duplicate and uncomment the commented code below.
                0522 C  In the duplicated and uncommented code, replace:
                0523 C    tttt -> BASIC TAPENADE TYPE NAME
                0524 C      (in character, boolean, integer, real, complex, pointer,...)
                0525 C    z7   -> LETTERSIZE FOR TYPE
                0526 C      (LETTER in s, b, i, r, c, p, ...) (SIZE is type size in bytes)
                0527 C    7    -> TYPE SIZE IN BYTES
                0528 C *********************************************************/
                0529 
                0530 C ************************* TTTT*7 ************************
                0531 c      BLOCK DATA TTTTS7
                0532 c      TTTT*7 adz7buf(512)
                0533 c      INTEGER adz7ibuf
                0534 c      COMMON /adz7fbuf/adz7buf,adz7ibuf
                0535 c      DATA adz7ibuf/1/
                0536 c      END
                0537 c
                0538 c      SUBROUTINE PUSHTTTT7(x)
                0539 c      TTTT*7 x, adz7buf(512)
                0540 c      INTEGER adz7ibuf
                0541 c      COMMON /adz7fbuf/adz7buf,adz7ibuf
                0542 c      CALL addftraffic(7)
                0543 c      adz7buf(adz7ibuf) = x
                0544 c      IF (adz7ibuf.eq.512) THEN
                0545 c         CALL PUSHTTTT7ARRAY(adz7buf, 512)
                0546 c         CALL addftraffic(-7*512)
                0547 c         adz7ibuf = 1
                0548 c      ELSE
                0549 c         adz7ibuf = adz7ibuf+1
                0550 c      ENDIF
                0551 c      END
                0552 c
                0553 c      SUBROUTINE POPTTTT7(x)
                0554 c      TTTT*7 x, adz7buf(512)
                0555 c      INTEGER adz7ibuf
                0556 c      COMMON /adz7fbuf/adz7buf,adz7ibuf
                0557 c      IF (adz7ibuf.le.1) THEN
                0558 c         CALL POPTTTT7ARRAY(adz7buf, 512)
                0559 c         adz7ibuf = 512
                0560 c      ELSE
                0561 c         adz7ibuf = adz7ibuf-1         
                0562 c      ENDIF
                0563 c      x = adz7buf(adz7ibuf)
                0564 c      END
                0565 
                0566 C *************** REPEATED ACCESS MECHANISM *********************
                0567 C     5 nested repeat levels should be more than enough!!
                0568       BLOCK DATA BUFFERREPEAT
                0569       INTEGER nbbufrepeat
                0570       INTEGER indexi4repeats(5)
                0571       INTEGER indexi8repeats(5)
                0572       INTEGER indexr4repeats(5)
                0573       INTEGER indexr8repeats(5)
                0574       INTEGER indexc8repeats(5)
                0575       INTEGER indexc16repeats(5)
                0576       INTEGER indexs1repeats(5)
                0577       INTEGER indexbitrepeats(5)
                0578       INTEGER indexptrrepeats(5)
                0579       COMMON /allbufferrepeats/indexi4repeats, indexi8repeats,
                0580      +     indexr4repeats, indexr8repeats, indexc8repeats,
                0581      +     indexc16repeats, indexs1repeats, indexbitrepeats,
                0582      +     indexptrrepeats, nbbufrepeat
                0583       DATA nbbufrepeat/0/
                0584       END
                0585 
                0586       SUBROUTINE ADSTACK_STARTREPEAT()
                0587       INTEGER nbbufrepeat
                0588       INTEGER indexi4repeats(5)
                0589       INTEGER indexi8repeats(5)
                0590       INTEGER indexr4repeats(5)
                0591       INTEGER indexr8repeats(5)
                0592       INTEGER indexc8repeats(5)
                0593       INTEGER indexc16repeats(5)
                0594       INTEGER indexs1repeats(5)
                0595       INTEGER indexbitrepeats(5)
                0596       INTEGER indexptrrepeats(5)
                0597       COMMON /allbufferrepeats/indexi4repeats, indexi8repeats,
                0598      +     indexr4repeats, indexr8repeats, indexc8repeats,
                0599      +     indexc16repeats, indexs1repeats, indexbitrepeats,
                0600      +     indexptrrepeats, nbbufrepeat
                0601       INTEGER*4 adi4buf(512)
                0602       INTEGER adi4ibuf
                0603       COMMON /adi4fbuf/adi4buf,adi4ibuf
                0604       INTEGER*8 adi8buf(512)
                0605       INTEGER adi8ibuf
                0606       COMMON /adi8fbuf/adi8buf,adi8ibuf
                0607       REAL*4 adr4buf(512)
                0608       INTEGER adr4ibuf
                0609       COMMON /adr4fbuf/adr4buf,adr4ibuf
                0610       REAL*8 adr8buf(512)
                0611       INTEGER adr8ibuf
                0612       COMMON /adr8fbuf/adr8buf,adr8ibuf
                0613       COMPLEX*8 adc8buf(512)
                0614       INTEGER adc8ibuf
                0615       COMMON /adc8fbuf/adc8buf,adc8ibuf
                0616       COMPLEX*16 adc16buf(512)
                0617       INTEGER adc16ibuf
                0618       COMMON /adc16fbuf/adc16buf,adc16ibuf
                0619       CHARACTER ads1buf(512)
                0620       INTEGER ads1ibuf
                0621       COMMON /ads1fbuf/ads1buf,ads1ibuf
                0622       INTEGER*4 adbitbuf
                0623       INTEGER adbitibuf
                0624       COMMON /adbitfbuf/adbitbuf, adbitibuf
                0625 c Create a new "buffers" repeat level:
                0626       nbbufrepeat = nbbufrepeat+1
                0627 c Also create a new repeat level for the main stack:
                0628       CALL STARTSTACKREPEAT1()
                0629 c Push all local buffers on the main stack.
                0630 c 3rd arg is 0 to deactivate the check for stack read-only zone:
                0631       if (adi4ibuf.gt.1) CALL PUSHNARRAY(adi4buf, 4*(adi4ibuf-1), 0)
                0632       if (adi8ibuf.gt.1) CALL PUSHNARRAY(adi8buf, 8*(adi8ibuf-1), 0)
                0633       if (adr4ibuf.gt.1) CALL PUSHNARRAY(adr4buf, 4*(adr4ibuf-1), 0)
                0634       if (adr8ibuf.gt.1) CALL PUSHNARRAY(adr8buf, 8*(adr8ibuf-1), 0)
                0635       if (adc8ibuf.gt.1) CALL PUSHNARRAY(adc8buf, 8*(adc8ibuf-1), 0)
                0636       if (adc16ibuf.gt.1)CALL PUSHNARRAY(adc16buf,16*(adc16ibuf-1),0)
                0637       if (ads1ibuf.gt.1) CALL PUSHNARRAY(ads1buf, ads1ibuf-1, 0)
                0638       CALL PUSHNARRAY(adbitbuf, 4, 0)
                0639 c      if (adptribuf.gt.1) CALL PUSHNARRAY(adptrbuf, 8*(adptribuf-1), 0)
                0640       indexi4repeats(nbbufrepeat) = adi4ibuf
                0641       indexi8repeats(nbbufrepeat) = adi8ibuf
                0642       indexr4repeats(nbbufrepeat) = adr4ibuf
                0643       indexr8repeats(nbbufrepeat) = adr8ibuf
                0644       indexc8repeats(nbbufrepeat) = adc8ibuf
                0645       indexc16repeats(nbbufrepeat) = adc16ibuf
                0646       indexs1repeats(nbbufrepeat) = ads1ibuf
                0647       indexbitrepeats(nbbufrepeat) = adbitibuf
                0648 c      indexptrrepeats(nbbufrepeat) = adptribuf
                0649 c Store current location as repeat location of new repeat level.
                0650 c Note that this repeat location protects below as read-only.
                0651 c Make the new repeat level the current repeat level  for the main stack:
                0652       CALL STARTSTACKREPEAT2()
                0653       END
                0654 
                0655 c Note: ADSTACK_RESETREPEAT() forces exit from any internal checkpointed sequence,
                0656 c   i.e. all nested push'es are forced popped.
                0657       SUBROUTINE ADSTACK_RESETREPEAT()
                0658       INTEGER nbbufrepeat
                0659       INTEGER indexi4repeats(5)
                0660       INTEGER indexi8repeats(5)
                0661       INTEGER indexr4repeats(5)
                0662       INTEGER indexr8repeats(5)
                0663       INTEGER indexc8repeats(5)
                0664       INTEGER indexc16repeats(5)
                0665       INTEGER indexs1repeats(5)
                0666       INTEGER indexbitrepeats(5)
                0667       INTEGER indexptrrepeats(5)
                0668       COMMON /allbufferrepeats/indexi4repeats, indexi8repeats,
                0669      +     indexr4repeats, indexr8repeats, indexc8repeats,
                0670      +     indexc16repeats, indexs1repeats, indexbitrepeats,
                0671      +     indexptrrepeats, nbbufrepeat
                0672       INTEGER*4 adi4buf(512)
                0673       INTEGER adi4ibuf
                0674       COMMON /adi4fbuf/adi4buf,adi4ibuf
                0675       INTEGER*8 adi8buf(512)
                0676       INTEGER adi8ibuf
                0677       COMMON /adi8fbuf/adi8buf,adi8ibuf
                0678       REAL*4 adr4buf(512)
                0679       INTEGER adr4ibuf
                0680       COMMON /adr4fbuf/adr4buf,adr4ibuf
                0681       REAL*8 adr8buf(512)
                0682       INTEGER adr8ibuf
                0683       COMMON /adr8fbuf/adr8buf,adr8ibuf
                0684       COMPLEX*8 adc8buf(512)
                0685       INTEGER adc8ibuf
                0686       COMMON /adc8fbuf/adc8buf,adc8ibuf
                0687       COMPLEX*16 adc16buf(512)
                0688       INTEGER adc16ibuf
                0689       COMMON /adc16fbuf/adc16buf,adc16ibuf
                0690       CHARACTER ads1buf(512)
                0691       INTEGER ads1ibuf
                0692       COMMON /ads1fbuf/ads1buf,ads1ibuf
                0693       INTEGER*4 adbitbuf
                0694       INTEGER adbitibuf
                0695       COMMON /adbitfbuf/adbitbuf, adbitibuf
                0696 c First stage of reset repeat for the main stack:
                0697       CALL RESETSTACKREPEAT1()
                0698 c Restore all local buffers:
                0699       adi4ibuf  = indexi4repeats(nbbufrepeat)
                0700       adi8ibuf  = indexi8repeats(nbbufrepeat)
                0701       adr4ibuf  = indexr4repeats(nbbufrepeat)
                0702       adr8ibuf  = indexr8repeats(nbbufrepeat)
                0703       adc8ibuf  = indexc8repeats(nbbufrepeat)
                0704       adc16ibuf = indexc16repeats(nbbufrepeat)
                0705       ads1ibuf  = indexs1repeats(nbbufrepeat)
                0706       adbitibuf = indexbitrepeats(nbbufrepeat)
                0707 c      adptribuf = indexptrrepeats(nbbufrepeat)
                0708 c      if (adptribuf.gt.1) CALL POPNARRAY(adptrbuf, 8*(adptribuf-1),0)
                0709       CALL POPNARRAY(adbitbuf, 4, 0)
                0710 c 3rd arg is 0 to deactivate the check for stack read-only zone:
                0711       if (ads1ibuf.gt.1) CALL POPNARRAY(ads1buf, ads1ibuf-1, 0)
                0712       if (adc16ibuf.gt.1)CALL POPNARRAY(adc16buf,16*(adc16ibuf-1),0)
                0713       if (adc8ibuf.gt.1) CALL POPNARRAY(adc8buf, 8*(adc8ibuf-1), 0)
                0714       if (adr8ibuf.gt.1) CALL POPNARRAY(adr8buf, 8*(adr8ibuf-1), 0)
                0715       if (adr4ibuf.gt.1) CALL POPNARRAY(adr4buf, 4*(adr4ibuf-1), 0)
                0716       if (adi8ibuf.gt.1) CALL POPNARRAY(adi8buf, 8*(adi8ibuf-1), 0)
                0717       if (adi4ibuf.gt.1) CALL POPNARRAY(adi4buf, 4*(adi4ibuf-1), 0)
                0718 c Second stage of reset repeat for the main stack:
                0719       CALL RESETSTACKREPEAT2()
                0720       END
                0721 
                0722 c Note: ADSTACK_ENDREPEAT() forces exit from any internal checkpointed sequence,
                0723 c   i.e. all nested push'es are forced popped.
                0724       SUBROUTINE ADSTACK_ENDREPEAT()
                0725       INTEGER nbbufrepeat
                0726       INTEGER indexi4repeats(5)
                0727       INTEGER indexi8repeats(5)
                0728       INTEGER indexr4repeats(5)
                0729       INTEGER indexr8repeats(5)
                0730       INTEGER indexc8repeats(5)
                0731       INTEGER indexc16repeats(5)
                0732       INTEGER indexs1repeats(5)
                0733       INTEGER indexbitrepeats(5)
                0734       INTEGER indexptrrepeats(5)
                0735       COMMON /allbufferrepeats/indexi4repeats, indexi8repeats,
                0736      +     indexr4repeats, indexr8repeats, indexc8repeats,
                0737      +     indexc16repeats, indexs1repeats, indexbitrepeats,
                0738      +     indexptrrepeats, nbbufrepeat
                0739 c End repeat for the main stack:
                0740       CALL ENDSTACKREPEAT() ;
                0741 c Remove top repeat level:
                0742       nbbufrepeat = nbbufrepeat-1
                0743       END
                0744 
                0745       SUBROUTINE SHOWI4BUFFERANDREPEATS(xbuf,xibuf,
                0746      +     xrepeats,nbbufrepeat)
                0747       INTEGER*4 xbuf(512)
                0748       INTEGER xibuf, xrepeats(5), nbbufrepeat
                0749       CHARACTER(len=3) seps(513)
                0750       INTEGER i
                0751       DO i=1,513
                0752          seps(i) = ''
                0753       ENDDO
                0754       seps(xibuf) = ' |'
                0755       WRITE (6,991) (seps(i),xbuf(i),i=1,512),
                0756      +     (xrepeats(i),i=1,nbbufrepeat)
                0757  991  FORMAT('      I4:',512(a2,i10.1),' REPEATS:',5i3)
                0758       END
                0759 
                0760       SUBROUTINE SHOWI8BUFFERANDREPEATS(xbuf,xibuf,
                0761      +     xrepeats,nbbufrepeat)
                0762       INTEGER*8 xbuf(512)
                0763       INTEGER xibuf, xrepeats(5), nbbufrepeat
                0764       CHARACTER(len=3) seps(513)
                0765       INTEGER i
                0766       DO i=1,513
                0767          seps(i) = ''
                0768       ENDDO
                0769       seps(xibuf) = ' |'
                0770       WRITE (6,991) (seps(i),xbuf(i),i=1,512),
                0771      +     (xrepeats(i),i=1,nbbufrepeat)
                0772  991  FORMAT('      I8:',512(a2,i20.1),' REPEATS:',5i3)
                0773       END
                0774 
                0775       SUBROUTINE SHOWR4BUFFERANDREPEATS(xbuf,xibuf,
                0776      +     xrepeats,nbbufrepeat)
                0777       REAL*4 xbuf(512)
                0778       INTEGER xibuf, xrepeats(5), nbbufrepeat
                0779       CHARACTER(len=3) seps(513)
                0780       INTEGER i
                0781       DO i=1,513
                0782          seps(i) = ''
                0783       ENDDO
                0784       seps(xibuf) = ' |'
                0785       WRITE (6,991) (seps(i),xbuf(i),i=1,512),
                0786      +     (xrepeats(i),i=1,nbbufrepeat)
                0787  991  FORMAT('      R4:',512(a2,e12.5),' REPEATS:',5i3)
                0788       END
                0789 
                0790       SUBROUTINE SHOWR8BUFFERANDREPEATS(xbuf,xibuf,
                0791      +     xrepeats,nbbufrepeat)
                0792       REAL*8 xbuf(512)
                0793       INTEGER xibuf, xrepeats(5), nbbufrepeat
                0794       CHARACTER(len=3) seps(513)
                0795       INTEGER i
                0796       DO i=1,513
                0797          seps(i) = ''
                0798       ENDDO
                0799       seps(xibuf) = ' |'
                0800       WRITE (6,991) (seps(i),xbuf(i),i=1,512),
                0801      +     (xrepeats(i),i=1,nbbufrepeat)
                0802  991  FORMAT('      R8:',512(a2,d12.5),' REPEATS:',5i3)
                0803       END
                0804 
                0805       SUBROUTINE SHOWC8BUFFERANDREPEATS(xbuf,xibuf,
                0806      +     xrepeats,nbbufrepeat)
                0807       COMPLEX*8 xbuf(512)
                0808       INTEGER xibuf, xrepeats(5), nbbufrepeat
                0809       CHARACTER(len=3) seps(513)
                0810       INTEGER i
                0811       DO i=1,513
                0812          seps(i) = ''
                0813       ENDDO
                0814       seps(xibuf) = ' |'
                0815       WRITE (6,991) (seps(i),xbuf(i),i=1,512),
                0816      +     (xrepeats(i),i=1,nbbufrepeat)
                0817  991  FORMAT('      C8:',512(a2,'(',e12.5,' i',e12.5,')'),
                0818      +     ' REPEATS:',5i3)
                0819       END
                0820 
                0821       SUBROUTINE SHOWC16BUFFERANDREPEATS(xbuf,xibuf,
                0822      +     xrepeats,nbbufrepeat)
                0823       COMPLEX*16 xbuf(512)
                0824       INTEGER xibuf, xrepeats(5), nbbufrepeat
                0825       CHARACTER(len=3) seps(513)
                0826       INTEGER i
                0827       DO i=1,513
                0828          seps(i) = ''
                0829       ENDDO
                0830       seps(xibuf) = ' |'
                0831       WRITE (6,991) (seps(i),xbuf(i),i=1,512),
                0832      +     (xrepeats(i),i=1,nbbufrepeat)
                0833  991  FORMAT('      C16:',512(a2,'(',d12.5,' i',d12.5,')'),
                0834      +     ' REPEATS:',5i3)
                0835       END
                0836 
                0837       SUBROUTINE SHOWS1BUFFERANDREPEATS(xbuf,xibuf,
                0838      +     xrepeats,nbbufrepeat)
                0839       CHARACTER xbuf(512)
                0840       INTEGER xibuf, xrepeats(5), nbbufrepeat
                0841       CHARACTER(len=3) seps(513)
                0842       INTEGER i
                0843       DO i=1,513
                0844          seps(i) = ''
                0845       ENDDO
                0846       seps(xibuf) = ' |'
                0847       WRITE (6,991) (seps(i),xbuf(i),i=1,512),
                0848      +     (xrepeats(i),i=1,nbbufrepeat)
                0849  991  FORMAT('      STR:',512(a2,a1),
                0850      +     ' REPEATS:',5i3)
                0851       END
                0852 
                0853       SUBROUTINE SHOWBITBUFFERANDREPEATS(xbuf,xibuf,
                0854      +     xrepeats,nbbufrepeat)
                0855       INTEGER*4 xbuf
                0856       INTEGER xibuf, xrepeats(5), nbbufrepeat,i
                0857       WRITE (6,991) xibuf,xbuf,(xrepeats(i),i=1,nbbufrepeat)
                0858  991  FORMAT('      BITS:',i2,' in ',z8,'     REPEATS:',5i3)
                0859       END
                0860 
                0861       SUBROUTINE SHOWSTACKANDBUFFERS(locationName)
                0862       CHARACTER(*) locationName
                0863       INTEGER nbbufrepeat
                0864       INTEGER indexi4repeats(5)
                0865       INTEGER indexi8repeats(5)
                0866       INTEGER indexr4repeats(5)
                0867       INTEGER indexr8repeats(5)
                0868       INTEGER indexc8repeats(5)
                0869       INTEGER indexc16repeats(5)
                0870       INTEGER indexs1repeats(5)
                0871       INTEGER indexbitrepeats(5)
                0872       INTEGER indexptrrepeats(5)
                0873       COMMON /allbufferrepeats/indexi4repeats, indexi8repeats,
                0874      +     indexr4repeats, indexr8repeats, indexc8repeats,
                0875      +     indexc16repeats, indexs1repeats, indexbitrepeats,
                0876      +     indexptrrepeats, nbbufrepeat
                0877       INTEGER*4 adi4buf(512)
                0878       INTEGER adi4ibuf
                0879       COMMON /adi4fbuf/adi4buf,adi4ibuf
                0880       INTEGER*8 adi8buf(512)
                0881       INTEGER adi8ibuf
                0882       COMMON /adi8fbuf/adi8buf,adi8ibuf
                0883       REAL*4 adr4buf(512)
                0884       INTEGER adr4ibuf
                0885       COMMON /adr4fbuf/adr4buf,adr4ibuf
                0886       REAL*8 adr8buf(512)
                0887       INTEGER adr8ibuf
                0888       COMMON /adr8fbuf/adr8buf,adr8ibuf
                0889       COMPLEX*8 adc8buf(512)
                0890       INTEGER adc8ibuf
                0891       COMMON /adc8fbuf/adc8buf,adc8ibuf
                0892       COMPLEX*16 adc16buf(512)
                0893       INTEGER adc16ibuf
                0894       COMMON /adc16fbuf/adc16buf,adc16ibuf
                0895       CHARACTER ads1buf(512)
                0896       INTEGER ads1ibuf
                0897       COMMON /ads1fbuf/ads1buf,ads1ibuf
                0898       INTEGER*4 adbitbuf
                0899       INTEGER adbitibuf
                0900       COMMON /adbitfbuf/adbitbuf, adbitibuf
                0901       print *,locationName
                0902       CALL SHOWSTACK()
                0903       CALL SHOWI4BUFFERANDREPEATS(adi4buf,adi4ibuf,
                0904      +     indexi4repeats,nbbufrepeat)
                0905       CALL SHOWI8BUFFERANDREPEATS(adi8buf,adi8ibuf,
                0906      +     indexi8repeats,nbbufrepeat)
                0907       CALL SHOWR4BUFFERANDREPEATS(adr4buf,adr4ibuf,
                0908      +     indexr4repeats,nbbufrepeat)
                0909       CALL SHOWR8BUFFERANDREPEATS(adr8buf,adr8ibuf,
                0910      +     indexr8repeats,nbbufrepeat)
                0911       CALL SHOWC8BUFFERANDREPEATS(adc8buf,adc8ibuf,
                0912      +     indexc8repeats,nbbufrepeat)
                0913       CALL SHOWC16BUFFERANDREPEATS(adc16buf,adc16ibuf,
                0914      +     indexc16repeats,nbbufrepeat)
                0915       CALL SHOWS1BUFFERANDREPEATS(ads1buf,ads1ibuf,
                0916      +     indexs1repeats,nbbufrepeat)
                0917       CALL SHOWBITBUFFERANDREPEATS(adbitbuf,adbitibuf,
                0918      +     indexbitrepeats,nbbufrepeat)
                0919 c No pointer buffer so far...
                0920       END
                0921 
                0922       SUBROUTINE SHOWSTACKANDBUFFERSSIZE(pos)
                0923       INTEGER*4 pos
                0924       INTEGER*4 adi4buf(512)
                0925       INTEGER adi4ibuf
                0926       COMMON /adi4fbuf/adi4buf,adi4ibuf
                0927       INTEGER*8 adi8buf(512)
                0928       INTEGER adi8ibuf
                0929       COMMON /adi8fbuf/adi8buf,adi8ibuf
                0930       REAL*4 adr4buf(512)
                0931       INTEGER adr4ibuf
                0932       COMMON /adr4fbuf/adr4buf,adr4ibuf
                0933       REAL*8 adr8buf(512)
                0934       INTEGER adr8ibuf
                0935       COMMON /adr8fbuf/adr8buf,adr8ibuf
                0936       COMPLEX*8 adc8buf(512)
                0937       INTEGER adc8ibuf
                0938       COMMON /adc8fbuf/adc8buf,adc8ibuf
                0939       COMPLEX*16 adc16buf(512)
                0940       INTEGER adc16ibuf
                0941       COMMON /adc16fbuf/adc16buf,adc16ibuf
                0942       CHARACTER ads1buf(512)
                0943       INTEGER ads1ibuf
                0944       COMMON /ads1fbuf/ads1buf,ads1ibuf
                0945       INTEGER*4 adbitbuf
                0946       INTEGER adbitibuf
                0947       COMMON /adbitfbuf/adbitbuf, adbitibuf
                0948       CALL SHOWSTACKSIZE(adi4ibuf-1,adi8ibuf-1,adr4ibuf-1,adr8ibuf-1,
                0949      +     adc8ibuf-1,adc16ibuf-1,ads1ibuf-1,adbitibuf-1,0,pos)
                0950       END
                0951 
                0952 C=========== MEASUREMENT OF PUSH TRAFFIC ==========
                0953 
                0954       BLOCK DATA BUFTRAFFICBLOCK
                0955       INTEGER*8 buffertraffic
                0956       COMMON /BUFTRAFFIC/buffertraffic
                0957       DATA buffertraffic/0/
                0958       END
                0959 
                0960       subroutine addftraffic(n)
                0961       INTEGER n
                0962       INTEGER*8 buffertraffic
                0963       COMMON /BUFTRAFFIC/buffertraffic
                0964       buffertraffic = buffertraffic+n
                0965       END
                0966 
                0967       SUBROUTINE ADSTACK_SHOWTRAFFIC()
                0968       INTEGER*8 buffertraffic
                0969       COMMON /BUFTRAFFIC/buffertraffic
                0970       call SHOWTOTALTRAFFIC(buffertraffic)
                0971       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!